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$
  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       --  If either operand missing, then this is an error, but ignore
 529       --  it (and pretend we have a cover) if errors already detected,
 530       --  since this may simply mean we have malformed trees.
 531
 532       if No (T1) or else No (T2) then
 533          if Total_Errors_Detected /= 0 then
 534             return True;
 535          else
 536             raise Program_Error;
 537          end if;
 538       end if;
 539
 540       --  Simplest case: same types are compatible, and types that have the
 541       --  same base type and are not generic actuals are compatible. Generic
 542       --  actuals  belong to their class but are not compatible with other
 543       --  types of their class, and in particular with other generic actuals.
 544       --  They are however compatible with their own subtypes, and itypes
 545       --  with the same base are compatible as well. Similary, constrained
 546       --  subtypes obtained from expressions of an unconstrained nominal type
 547       --  are compatible with the base type (may lead to spurious ambiguities
 548       --  in obscure cases ???)
 549
 550       --  Generic actuals require special treatment to avoid spurious ambi-
 551       --  guities in an instance, when two formal types are instantiated with
 552       --  the same actual, so that different subprograms end up with the same
 553       --  signature in the instance.
 554
 555       if T1 = T2 then
 556          return True;
 557
 558       elsif Base_Type (T1) = Base_Type (T2) then
 559          if not Is_Generic_Actual_Type (T1) then
 560             return True;
 561          else
 562             return (not Is_Generic_Actual_Type (T2)
 563                      or else Is_Itype (T1)
 564                      or else Is_Itype (T2)
 565                      or else Is_Constr_Subt_For_U_Nominal (T1)
 566                      or else Is_Constr_Subt_For_U_Nominal (T2)
 567                      or else Scope (T1) /= Scope (T2));
 568          end if;
 569
 570       --  Literals are compatible with types in  a given "class"
 571
 572       elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
 573         or else (T2 = Universal_Real    and then Is_Real_Type (T1))
 574         or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
 575         or else (T2 = Any_Fixed         and then Is_Fixed_Point_Type (T1))
 576         or else (T2 = Any_String        and then Is_String_Type (T1))
 577         or else (T2 = Any_Character     and then Is_Character_Type (T1))
 578         or else (T2 = Any_Access        and then Is_Access_Type (T1))
 579       then
 580          return True;
 581
 582       --  The context may be class wide.
 583
 584       elsif Is_Class_Wide_Type (T1)
 585         and then Is_Ancestor (Root_Type (T1), T2)
 586       then
 587          return True;
 588
 589       elsif Is_Class_Wide_Type (T1)
 590         and then Is_Class_Wide_Type (T2)
 591         and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
 592       then
 593          return True;
 594
 595       --  In a dispatching call the actual may be class-wide
 596
 597       elsif Is_Class_Wide_Type (T2)
 598         and then Base_Type (Root_Type (T2)) = Base_Type (T1)
 599       then
 600          return True;
 601
 602       --  Some contexts require a class of types rather than a specific type
 603
 604       elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
 605         or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
 606         or else (T1 = Any_Real and then Is_Real_Type (T2))
 607         or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
 608         or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
 609       then
 610          return True;
 611
 612       --  An aggregate is compatible with an array or record type
 613
 614       elsif T2 = Any_Composite
 615         and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
 616       then
 617          return True;
 618
 619       --  If the expected type is an anonymous access, the designated
 620       --  type must cover that of the expression.
 621
 622       elsif Ekind (T1) = E_Anonymous_Access_Type
 623         and then Is_Access_Type (T2)
 624         and then Covers (Designated_Type (T1), Designated_Type (T2))
 625       then
 626          return True;
 627
 628       --  An Access_To_Subprogram is compatible with itself, or with an
 629       --  anonymous type created for an attribute reference Access.
 630
 631       elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type
 632                or else
 633              Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type)
 634         and then Is_Access_Type (T2)
 635         and then (not Comes_From_Source (T1)
 636                    or else not Comes_From_Source (T2))
 637         and then (Is_Overloadable (Designated_Type (T2))
 638                     or else
 639                   Ekind (Designated_Type (T2)) = E_Subprogram_Type)
 640         and then
 641           Type_Conformant (Designated_Type (T1), Designated_Type (T2))
 642         and then
 643           Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
 644       then
 645          return True;
 646
 647       elsif Is_Record_Type (T1)
 648         and then (Is_Remote_Call_Interface (T1)
 649                    or else Is_Remote_Types (T1))
 650         and then Present (Corresponding_Remote_Type (T1))
 651       then
 652          return Covers (Corresponding_Remote_Type (T1), T2);
 653
 654       elsif Ekind (T2) = E_Access_Attribute_Type
 655         and then (Ekind (Base_Type (T1)) = E_General_Access_Type
 656               or else Ekind (Base_Type (T1)) = E_Access_Type)
 657         and then Covers (Designated_Type (T1), Designated_Type (T2))
 658       then
 659          --  If the target type is a RACW type while the source is an access
 660          --  attribute type, we are building a RACW that may be exported.
 661
 662          if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then
 663             Set_Has_RACW (Current_Sem_Unit);
 664          end if;
 665
 666          return True;
 667
 668       elsif Ekind (T2) = E_Allocator_Type
 669         and then Is_Access_Type (T1)
 670         and then Covers (Designated_Type (T1), Designated_Type (T2))
 671       then
 672          return True;
 673
 674       --  A boolean operation on integer literals is compatible with a
 675       --  modular context.
 676
 677       elsif T2 = Any_Modular
 678         and then Is_Modular_Integer_Type (T1)
 679       then
 680          return True;
 681
 682       --  The actual type may be the result of a previous error
 683
 684       elsif Base_Type (T2) = Any_Type then
 685          return True;
 686
 687       --  A packed array type covers its corresponding non-packed type.
 688       --  This is not legitimate Ada, but allows the omission of a number
 689       --  of otherwise useless unchecked conversions, and since this can
 690       --  only arise in (known correct) expanded code, no harm is done
 691
 692       elsif Is_Array_Type (T2)
 693         and then Is_Packed (T2)
 694         and then T1 = Packed_Array_Type (T2)
 695       then
 696          return True;
 697
 698       --  Similarly an array type covers its corresponding packed array type
 699
 700       elsif Is_Array_Type (T1)
 701         and then Is_Packed (T1)
 702         and then T2 = Packed_Array_Type (T1)
 703       then
 704          return True;
 705
 706       --  In an instance the proper view may not always be correct for
 707       --  private types, but private and full view are compatible. This
 708       --  removes spurious errors from nested instantiations that involve,
 709       --  among other things, types derived from privated types.
 710
 711       elsif In_Instance
 712         and then Is_Private_Type (T1)
 713         and then ((Present (Full_View (T1))
 714                     and then Covers (Full_View (T1), T2))
 715           or else Base_Type (T1) = T2
 716           or else Base_Type (T2) = T1)
 717       then
 718          return True;
 719
 720       --  In the expansion of inlined bodies, types are compatible if they
 721       --  are structurally equivalent.
 722
 723       elsif In_Inlined_Body
 724         and then (Underlying_Type (T1) = Underlying_Type (T2)
 725                    or else (Is_Access_Type (T1)
 726                               and then Is_Access_Type (T2)
 727                               and then
 728                                 Designated_Type (T1) = Designated_Type (T2))
 729                    or else (T1 = Any_Access
 730                               and then Is_Access_Type (Underlying_Type (T2))))
 731       then
 732          return True;
 733
 734       --  Otherwise it doesn't cover!
 735
 736       else
 737          return False;
 738       end if;
 739    end Covers;
 740
 741    ------------------
 742    -- Disambiguate --
 743    ------------------
 744
 745    function Disambiguate
 746      (N      : Node_Id;
 747       I1, I2 : Interp_Index;
 748       Typ    : Entity_Id)
 749       return   Interp
 750    is
 751       I           : Interp_Index;
 752       It          : Interp;
 753       It1, It2    : Interp;
 754       Nam1, Nam2  : Entity_Id;
 755       Predef_Subp : Entity_Id;
 756       User_Subp   : Entity_Id;
 757
 758       function Matches (Actual, Formal : Node_Id) return Boolean;
 759       --  Look for exact type match in an instance, to remove spurious
 760       --  ambiguities when two formal types have the same actual.
 761
 762       function Standard_Operator return Boolean;
 763
 764       function Remove_Conversions return Interp;
 765       --  Last chance for pathological cases involving comparisons on
 766       --  literals, and user overloadings of the same operator. Such
 767       --  pathologies have been removed from the ACVC, but still appear in
 768       --  two DEC tests, with the following notable quote from Ben Brosgol:
 769       --
 770       --  [Note: I disclaim all credit/responsibility/blame for coming up with
 771       --  this example;  Robert Dewar brought it to our attention, since it
 772       --  is apparently found in the ACVC 1.5. I did not attempt to find
 773       --  the reason in the Reference Manual that makes the example legal,
 774       --  since I was too nauseated by it to want to pursue it further.]
 775       --
 776       --  Accordingly, this is not a fully recursive solution, but it handles
 777       --  DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
 778       --  pathology in the other direction with calls whose multiple overloaded
 779       --  actuals make them truly unresolvable.
 780
 781       -------------
 782       -- Matches --
 783       -------------
 784
 785       function Matches (Actual, Formal : Node_Id) return Boolean is
 786          T1 : constant Entity_Id := Etype (Actual);
 787          T2 : constant Entity_Id := Etype (Formal);
 788
 789       begin
 790          return T1 = T2
 791            or else
 792              (Is_Numeric_Type (T2)
 793                and then
 794              (T1 = Universal_Real or else T1 = Universal_Integer));
 795       end Matches;
 796
 797       ------------------------
 798       -- Remove_Conversions --
 799       ------------------------
 800
 801       function Remove_Conversions return Interp is
 802          I    : Interp_Index;
 803          It   : Interp;
 804          It1  : Interp;
 805          F1   : Entity_Id;
 806          Act1 : Node_Id;
 807          Act2 : Node_Id;
 808
 809       begin
 810          It1   := No_Interp;
 811          Get_First_Interp (N, I, It);
 812
 813          while Present (It.Typ) loop
 814
 815             if not Is_Overloadable (It.Nam) then
 816                return No_Interp;
 817             end if;
 818
 819             F1 := First_Formal (It.Nam);
 820
 821             if No (F1) then
 822                return It1;
 823
 824             else
 825                if Nkind (N) = N_Function_Call
 826                  or else Nkind (N) = N_Procedure_Call_Statement
 827                then
 828                   Act1 := First_Actual (N);
 829
 830                   if Present (Act1) then
 831                      Act2 := Next_Actual (Act1);
 832                   else
 833                      Act2 := Empty;
 834                   end if;
 835
 836                elsif Nkind (N) in N_Unary_Op then
 837                   Act1 := Right_Opnd (N);
 838                   Act2 := Empty;
 839
 840                elsif Nkind (N) in N_Binary_Op then
 841                   Act1 := Left_Opnd (N);
 842                   Act2 := Right_Opnd (N);
 843
 844                else
 845                   return It1;
 846                end if;
 847
 848                if Nkind (Act1) in N_Op
 849                  and then Is_Overloaded (Act1)
 850                  and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
 851                             or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
 852                  and then Has_Compatible_Type (Act1, Standard_Boolean)
 853                  and then Etype (F1) = Standard_Boolean
 854                then
 855
 856                   if It1 /= No_Interp then
 857                      return No_Interp;
 858
 859                   elsif Present (Act2)
 860                     and then Nkind (Act2) in N_Op
 861                     and then Is_Overloaded (Act2)
 862                     and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
 863                                 or else
 864                               Nkind (Right_Opnd (Act1)) = N_Real_Literal)
 865                     and then Has_Compatible_Type (Act2, Standard_Boolean)
 866                   then
 867                      --  The preference rule on the first actual is not
 868                      --  sufficient to disambiguate.
 869
 870                      goto Next_Interp;
 871
 872                   else
 873                      It1 := It;
 874                   end if;
 875                end if;
 876             end if;
 877
 878             <<Next_Interp>>
 879                Get_Next_Interp (I, It);
 880          end loop;
 881
 882          if Serious_Errors_Detected > 0 then
 883
 884             --  After some error, a formal may have Any_Type and yield
 885             --  a spurious match. To avoid cascaded errors if possible,
 886             --  check for such a formal in either candidate.
 887
 888             declare
 889                Formal : Entity_Id;
 890
 891             begin
 892                Formal := First_Formal (Nam1);
 893                while Present (Formal) loop
 894                   if Etype (Formal) = Any_Type then
 895                      return Disambiguate.It2;
 896                   end if;
 897
 898                   Next_Formal (Formal);
 899                end loop;
 900
 901                Formal := First_Formal (Nam2);
 902                while Present (Formal) loop
 903                   if Etype (Formal) = Any_Type then
 904                      return Disambiguate.It1;
 905                   end if;
 906
 907                   Next_Formal (Formal);
 908                end loop;
 909             end;
 910          end if;
 911
 912          return It1;
 913       end Remove_Conversions;
 914
 915       -----------------------
 916       -- Standard_Operator --
 917       -----------------------
 918
 919       function Standard_Operator return Boolean is
 920          Nam : Node_Id;
 921
 922       begin
 923          if Nkind (N) in N_Op then
 924             return True;
 925
 926          elsif Nkind (N) = N_Function_Call then
 927             Nam := Name (N);
 928
 929             if Nkind (Nam) /= N_Expanded_Name then
 930                return True;
 931             else
 932                return Entity (Prefix (Nam)) = Standard_Standard;
 933             end if;
 934          else
 935             return False;
 936          end if;
 937       end Standard_Operator;
 938
 939    --  Start of processing for Disambiguate
 940
 941    begin
 942       --  Recover the two legal interpretations.
 943
 944       Get_First_Interp (N, I, It);
 945
 946       while I /= I1 loop
 947          Get_Next_Interp (I, It);
 948       end loop;
 949
 950       It1  := It;
 951       Nam1 := It.Nam;
 952
 953       while I /= I2 loop
 954          Get_Next_Interp (I, It);
 955       end loop;
 956
 957       It2  := It;
 958       Nam2 := It.Nam;
 959
 960       --  If the context is universal, the predefined operator is preferred.
 961       --  This includes bounds in numeric type declarations, and expressions
 962       --  in type conversions. If no interpretation yields a universal type,
 963       --  then we must check whether the user-defined entity hides the prede-
 964       --  fined one.
 965
 966       if Chars (Nam1) in  Any_Operator_Name
 967         and then Standard_Operator
 968       then
 969          if        Typ = Universal_Integer
 970            or else Typ = Universal_Real
 971            or else Typ = Any_Integer
 972            or else Typ = Any_Discrete
 973            or else Typ = Any_Real
 974            or else Typ = Any_Type
 975          then
 976             --  Find an interpretation that yields the universal type, or else
 977             --  a predefined operator that yields a predefined numeric type.
 978
 979             declare
 980                Candidate : Interp := No_Interp;
 981             begin
 982                Get_First_Interp (N, I, It);
 983
 984                while Present (It.Typ) loop
 985                   if (Covers (Typ, It.Typ)
 986                        or else Typ = Any_Type)
 987                     and then
 988                      (It.Typ = Universal_Integer
 989                        or else It.Typ = Universal_Real)
 990                   then
 991                      return It;
 992
 993                   elsif Covers (Typ, It.Typ)
 994                     and then Scope (It.Typ) = Standard_Standard
 995                     and then Scope (It.Nam) = Standard_Standard
 996                     and then Is_Numeric_Type (It.Typ)
 997                   then
 998                      Candidate := It;
 999                   end if;
1000
1001                   Get_Next_Interp (I, It);
1002                end loop;
1003
1004                if Candidate /= No_Interp then
1005                   return Candidate;
1006                end if;
1007             end;
1008
1009          elsif Chars (Nam1) /= Name_Op_Not
1010            and then (Typ = Standard_Boolean
1011              or else Typ = Any_Boolean)
1012          then
1013             --  Equality or comparison operation. Choose predefined operator
1014             --  if arguments are universal. The node may be an operator, a
1015             --  name, or a function call, so unpack arguments accordingly.
1016
1017             declare
1018                Arg1, Arg2 : Node_Id;
1019
1020             begin
1021                if Nkind (N) in N_Op then
1022                   Arg1 := Left_Opnd  (N);
1023                   Arg2 := Right_Opnd (N);
1024
1025                elsif Is_Entity_Name (N)
1026                  or else Nkind (N) = N_Operator_Symbol
1027                then
1028                   Arg1 := First_Entity (Entity (N));
1029                   Arg2 := Next_Entity (Arg1);
1030
1031                else
1032                   Arg1 := First_Actual (N);
1033                   Arg2 := Next_Actual (Arg1);
1034                end if;
1035
1036                if Present (Arg2)
1037                  and then Present (Universal_Interpretation (Arg1))
1038                  and then Universal_Interpretation (Arg2) =
1039                           Universal_Interpretation (Arg1)
1040                then
1041                   Get_First_Interp (N, I, It);
1042
1043                   while Scope (It.Nam) /= Standard_Standard loop
1044                      Get_Next_Interp (I, It);
1045                   end loop;
1046
1047                   return It;
1048                end if;
1049             end;
1050          end if;
1051       end if;
1052
1053       --  If no universal interpretation, check whether user-defined operator
1054       --  hides predefined one, as well as other special cases. If the node
1055       --  is a range, then one or both bounds are ambiguous. Each will have
1056       --  to be disambiguated w.r.t. the context type. The type of the range
1057       --  itself is imposed by the context, so we can return either legal
1058       --  interpretation.
1059
1060       if Ekind (Nam1) = E_Operator then
1061          Predef_Subp := Nam1;
1062          User_Subp   := Nam2;
1063
1064       elsif Ekind (Nam2) = E_Operator then
1065          Predef_Subp := Nam2;
1066          User_Subp   := Nam1;
1067
1068       elsif Nkind (N) = N_Range then
1069          return It1;
1070
1071       --  If two user defined-subprograms are visible, it is a true ambiguity,
1072       --  unless one of them is an entry and the context is a conditional or
1073       --  timed entry call, or unless we are within an instance and this is
1074       --  results from two formals types with the same actual.
1075
1076       else
1077          if Nkind (N) = N_Procedure_Call_Statement
1078            and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1079            and then N = Entry_Call_Statement (Parent (N))
1080          then
1081             if Ekind (Nam2) = E_Entry then
1082                return It2;
1083             elsif Ekind (Nam1) = E_Entry then
1084                return It1;
1085             else
1086                return No_Interp;
1087             end if;
1088
1089          --  If the ambiguity occurs within an instance, it is due to several
1090          --  formal types with the same actual. Look for an exact match
1091          --  between the types of the formals of the overloadable entities,
1092          --  and the actuals in the call, to recover the unambiguous match
1093          --  in the original generic.
1094
1095          elsif In_Instance then
1096             if (Nkind (N) = N_Function_Call
1097               or else Nkind (N) = N_Procedure_Call_Statement)
1098             then
1099                declare
1100                   Actual : Node_Id;
1101                   Formal : Entity_Id;
1102
1103                begin
1104                   Actual := First_Actual (N);
1105                   Formal := First_Formal (Nam1);
1106                   while Present (Actual) loop
1107                      if Etype (Actual) /= Etype (Formal) then
1108                         return It2;
1109                      end if;
1110
1111                      Next_Actual (Actual);
1112                      Next_Formal (Formal);
1113                   end loop;
1114
1115                   return It1;
1116                end;
1117
1118             elsif Nkind (N) in N_Binary_Op then
1119
1120                if Matches (Left_Opnd (N), First_Formal (Nam1))
1121                  and then
1122                    Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1123                then
1124                   return It1;
1125                else
1126                   return It2;
1127                end if;
1128
1129             elsif Nkind (N) in  N_Unary_Op then
1130
1131                if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1132                   return It1;
1133                else
1134                   return It2;
1135                end if;
1136
1137             else
1138                return Remove_Conversions;
1139             end if;
1140          else
1141             return Remove_Conversions;
1142          end if;
1143       end if;
1144
1145       --  an implicit concatenation operator on a string type cannot be
1146       --  disambiguated from the predefined concatenation. This can only
1147       --  happen with concatenation of string literals.
1148
1149       if Chars (User_Subp) = Name_Op_Concat
1150         and then Ekind (User_Subp) = E_Operator
1151         and then Is_String_Type (Etype (First_Formal (User_Subp)))
1152       then
1153          return No_Interp;
1154
1155       --  If the user-defined operator is in  an open scope, or in the scope
1156       --  of the resulting type, or given by an expanded name that names its
1157       --  scope, it hides the predefined operator for the type. Exponentiation
1158       --  has to be special-cased because the implicit operator does not have
1159       --  a symmetric signature, and may not be hidden by the explicit one.
1160
1161       elsif (Nkind (N) = N_Function_Call
1162               and then Nkind (Name (N)) = N_Expanded_Name
1163               and then (Chars (Predef_Subp) /= Name_Op_Expon
1164                           or else Hides_Op (User_Subp, Predef_Subp))
1165               and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1166         or else Hides_Op (User_Subp, Predef_Subp)
1167       then
1168          if It1.Nam = User_Subp then
1169             return It1;
1170          else
1171             return It2;
1172          end if;
1173
1174       --  Otherwise, the predefined operator has precedence, or if the
1175       --  user-defined operation is directly visible we have a true ambiguity.
1176       --  If this is a fixed-point multiplication and division in Ada83 mode,
1177       --  exclude the universal_fixed operator, which often causes ambiguities
1178       --  in legacy code.
1179
1180       else
1181          if (In_Open_Scopes (Scope (User_Subp))
1182            or else Is_Potentially_Use_Visible (User_Subp))
1183            and then not In_Instance
1184          then
1185             if Is_Fixed_Point_Type (Typ)
1186               and then (Chars (Nam1) = Name_Op_Multiply
1187                          or else Chars (Nam1) = Name_Op_Divide)
1188               and then Ada_83
1189             then
1190                if It2.Nam = Predef_Subp then
1191                   return It1;
1192
1193                else
1194                   return It2;
1195                end if;
1196             else
1197                return No_Interp;
1198             end if;
1199
1200          elsif It1.Nam = Predef_Subp then
1201             return It1;
1202
1203          else
1204             return It2;
1205          end if;
1206       end if;
1207
1208    end Disambiguate;
1209
1210    ---------------------
1211    -- End_Interp_List --
1212    ---------------------
1213
1214    procedure End_Interp_List is
1215    begin
1216       All_Interp.Table (All_Interp.Last) := No_Interp;
1217       All_Interp.Increment_Last;
1218    end End_Interp_List;
1219
1220    -------------------------
1221    -- Entity_Matches_Spec --
1222    -------------------------
1223
1224    function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1225    begin
1226       --  Simple case: same entity kinds, type conformance is required.
1227       --  A parameterless function can also rename a literal.
1228
1229       if Ekind (Old_S) = Ekind (New_S)
1230         or else (Ekind (New_S) = E_Function
1231                   and then Ekind (Old_S) = E_Enumeration_Literal)
1232       then
1233          return Type_Conformant (New_S, Old_S);
1234
1235       elsif Ekind (New_S) = E_Function
1236         and then Ekind (Old_S) = E_Operator
1237       then
1238          return Operator_Matches_Spec (Old_S, New_S);
1239
1240       elsif Ekind (New_S) = E_Procedure
1241         and then Is_Entry (Old_S)
1242       then
1243          return Type_Conformant (New_S, Old_S);
1244
1245       else
1246          return False;
1247       end if;
1248    end Entity_Matches_Spec;
1249
1250    ----------------------
1251    -- Find_Unique_Type --
1252    ----------------------
1253
1254    function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1255       I  : Interp_Index;
1256       It : Interp;
1257       T  : Entity_Id := Etype (L);
1258       TR : Entity_Id := Any_Type;
1259
1260    begin
1261       if Is_Overloaded (R) then
1262          Get_First_Interp (R, I, It);
1263
1264          while Present (It.Typ) loop
1265             if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1266
1267                --  If several interpretations are possible and L is universal,
1268                --  apply preference rule.
1269
1270                if TR /= Any_Type then
1271
1272                   if (T = Universal_Integer or else T = Universal_Real)
1273                     and then It.Typ = T
1274                   then
1275                      TR := It.Typ;
1276                   end if;
1277
1278                else
1279                   TR := It.Typ;
1280                end if;
1281             end if;
1282
1283             Get_Next_Interp (I, It);
1284          end loop;
1285
1286          Set_Etype (R, TR);
1287
1288       --  In the non-overloaded case, the Etype of R is already set
1289       --  correctly.
1290
1291       else
1292          null;
1293       end if;
1294
1295       --  If one of the operands is Universal_Fixed, the type of the
1296       --  other operand provides the context.
1297
1298       if Etype (R) = Universal_Fixed then
1299          return T;
1300
1301       elsif T = Universal_Fixed then
1302          return Etype (R);
1303
1304       else
1305          return Specific_Type (T, Etype (R));
1306       end if;
1307
1308    end Find_Unique_Type;
1309
1310    ----------------------
1311    -- Get_First_Interp --
1312    ----------------------
1313
1314    procedure Get_First_Interp
1315      (N  : Node_Id;
1316       I  : out Interp_Index;
1317       It : out Interp)
1318    is
1319       Int_Ind : Interp_Index;
1320       O_N     : Node_Id;
1321
1322    begin
1323       --  If a selected component is overloaded because the selector has
1324       --  multiple interpretations, the node is a call to a protected
1325       --  operation or an indirect call. Retrieve the interpretation from
1326       --  the selector name. The selected component may be overloaded as well
1327       --  if the prefix is overloaded. That case is unchanged.
1328
1329       if Nkind (N) = N_Selected_Component
1330         and then Is_Overloaded (Selector_Name (N))
1331       then
1332          O_N := Selector_Name (N);
1333       else
1334          O_N := N;
1335       end if;
1336
1337       for Index in 0 .. Interp_Map.Last loop
1338          if Interp_Map.Table (Index).Node = O_N then
1339             Int_Ind := Interp_Map.Table (Index).Index;
1340             It := All_Interp.Table (Int_Ind);
1341             I := Int_Ind;
1342             return;
1343          end if;
1344       end loop;
1345
1346       --  Procedure should never be called if the node has no interpretations
1347
1348       raise Program_Error;
1349    end Get_First_Interp;
1350
1351    ----------------------
1352    --  Get_Next_Interp --
1353    ----------------------
1354
1355    procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
1356    begin
1357       I  := I + 1;
1358       It := All_Interp.Table (I);
1359    end Get_Next_Interp;
1360
1361    -------------------------
1362    -- Has_Compatible_Type --
1363    -------------------------
1364
1365    function Has_Compatible_Type
1366      (N    : Node_Id;
1367       Typ  : Entity_Id)
1368       return Boolean
1369    is
1370       I  : Interp_Index;
1371       It : Interp;
1372
1373    begin
1374       if N = Error then
1375          return False;
1376       end if;
1377
1378       if Nkind (N) = N_Subtype_Indication
1379         or else not Is_Overloaded (N)
1380       then
1381          return Covers (Typ, Etype (N))
1382            or else (not Is_Tagged_Type (Typ)
1383                      and then Ekind (Typ) /= E_Anonymous_Access_Type
1384                      and then Covers (Etype (N), Typ));
1385
1386       else
1387          Get_First_Interp (N, I, It);
1388
1389          while Present (It.Typ) loop
1390             if Covers (Typ, It.Typ)
1391               or else (not Is_Tagged_Type (Typ)
1392                         and then Ekind (Typ) /= E_Anonymous_Access_Type
1393                         and then Covers (It.Typ, Typ))
1394             then
1395                return True;
1396             end if;
1397
1398             Get_Next_Interp (I, It);
1399          end loop;
1400
1401          return False;
1402       end if;
1403    end Has_Compatible_Type;
1404
1405    --------------
1406    -- Hides_Op --
1407    --------------
1408
1409    function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
1410       Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
1411
1412    begin
1413       return Operator_Matches_Spec (Op, F)
1414         and then (In_Open_Scopes (Scope (F))
1415                     or else Scope (F) = Scope (Btyp)
1416                     or else (not In_Open_Scopes (Scope (Btyp))
1417                               and then not In_Use (Btyp)
1418                               and then not In_Use (Scope (Btyp))));
1419    end Hides_Op;
1420
1421    ------------------------
1422    -- Init_Interp_Tables --
1423    ------------------------
1424
1425    procedure Init_Interp_Tables is
1426    begin
1427       All_Interp.Init;
1428       Interp_Map.Init;
1429    end Init_Interp_Tables;
1430
1431    ---------------------
1432    -- Intersect_Types --
1433    ---------------------
1434
1435    function Intersect_Types (L, R : Node_Id) return Entity_Id is
1436       Index : Interp_Index;
1437       It    : Interp;
1438       Typ   : Entity_Id;
1439
1440       function Check_Right_Argument (T : Entity_Id) return Entity_Id;
1441       --  Find interpretation of right arg that has type compatible with T
1442
1443       --------------------------
1444       -- Check_Right_Argument --
1445       --------------------------
1446
1447       function Check_Right_Argument (T : Entity_Id) return Entity_Id is
1448          Index : Interp_Index;
1449          It    : Interp;
1450          T2    : Entity_Id;
1451
1452       begin
1453          if not Is_Overloaded (R) then
1454             return Specific_Type (T, Etype (R));
1455
1456          else
1457             Get_First_Interp (R, Index, It);
1458
1459             loop
1460                T2 := Specific_Type (T, It.Typ);
1461
1462                if T2 /= Any_Type then
1463                   return T2;
1464                end if;
1465
1466                Get_Next_Interp (Index, It);
1467                exit when No (It.Typ);
1468             end loop;
1469
1470             return Any_Type;
1471          end if;
1472       end Check_Right_Argument;
1473
1474    --  Start processing for Intersect_Types
1475
1476    begin
1477       if Etype (L) = Any_Type or else Etype (R) = Any_Type then
1478          return Any_Type;
1479       end if;
1480
1481       if not Is_Overloaded (L) then
1482          Typ := Check_Right_Argument (Etype (L));
1483
1484       else
1485          Typ := Any_Type;
1486          Get_First_Interp (L, Index, It);
1487
1488          while Present (It.Typ) loop
1489             Typ := Check_Right_Argument (It.Typ);
1490             exit when Typ /= Any_Type;
1491             Get_Next_Interp (Index, It);
1492          end loop;
1493
1494       end if;
1495
1496       --  If Typ is Any_Type, it means no compatible pair of types was found
1497
1498       if Typ = Any_Type then
1499
1500          if Nkind (Parent (L)) in N_Op then
1501             Error_Msg_N ("incompatible types for operator", Parent (L));
1502
1503          elsif Nkind (Parent (L)) = N_Range then
1504             Error_Msg_N ("incompatible types given in constraint", Parent (L));
1505
1506          else
1507             Error_Msg_N ("incompatible types", Parent (L));
1508          end if;
1509       end if;
1510
1511       return Typ;
1512    end Intersect_Types;
1513
1514    -----------------
1515    -- Is_Ancestor --
1516    -----------------
1517
1518    function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
1519       Par : Entity_Id;
1520
1521    begin
1522       if Base_Type (T1) = Base_Type (T2) then
1523          return True;
1524
1525       elsif Is_Private_Type (T1)
1526         and then Present (Full_View (T1))
1527         and then Base_Type (T2) = Base_Type (Full_View (T1))
1528       then
1529          return True;
1530
1531       else
1532          Par := Etype (T2);
1533
1534          loop
1535             if Base_Type (T1) = Base_Type (Par)
1536               or else (Is_Private_Type (T1)
1537                         and then Present (Full_View (T1))
1538                         and then Base_Type (Par) = Base_Type (Full_View (T1)))
1539             then
1540                return True;
1541
1542             elsif Is_Private_Type (Par)
1543               and then Present (Full_View (Par))
1544               and then Full_View (Par) = Base_Type (T1)
1545             then
1546                return True;
1547
1548             elsif Etype (Par) /= Par then
1549                Par := Etype (Par);
1550             else
1551                return False;
1552             end if;
1553          end loop;
1554       end if;
1555    end Is_Ancestor;
1556
1557    -------------------
1558    -- Is_Subtype_Of --
1559    -------------------
1560
1561    function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
1562       S : Entity_Id;
1563
1564    begin
1565       S := Ancestor_Subtype (T1);
1566       while Present (S) loop
1567          if S = T2 then
1568             return True;
1569          else
1570             S := Ancestor_Subtype (S);
1571          end if;
1572       end loop;
1573
1574       return False;
1575    end Is_Subtype_Of;
1576
1577    -----------------
1578    -- New_Interps --
1579    -----------------
1580
1581    procedure New_Interps (N : Node_Id)  is
1582    begin
1583       Interp_Map.Increment_Last;
1584       All_Interp.Increment_Last;
1585       Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
1586       All_Interp.Table (All_Interp.Last) := No_Interp;
1587       Set_Is_Overloaded (N, True);
1588    end New_Interps;
1589
1590    ---------------------------
1591    -- Operator_Matches_Spec --
1592    ---------------------------
1593
1594    function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
1595       Op_Name : constant Name_Id   := Chars (Op);
1596       T       : constant Entity_Id := Etype (New_S);
1597       New_F   : Entity_Id;
1598       Old_F   : Entity_Id;
1599       Num     : Int;
1600       T1      : Entity_Id;
1601       T2      : Entity_Id;
1602
1603    begin
1604       --  To verify that a predefined operator matches a given signature,
1605       --  do a case analysis of the operator classes. Function can have one
1606       --  or two formals and must have the proper result type.
1607
1608       New_F := First_Formal (New_S);
1609       Old_F := First_Formal (Op);
1610       Num := 0;
1611
1612       while Present (New_F) and then Present (Old_F) loop
1613          Num := Num + 1;
1614          Next_Formal (New_F);
1615          Next_Formal (Old_F);
1616       end loop;
1617
1618       --  Definite mismatch if different number of parameters
1619
1620       if Present (Old_F) or else Present (New_F) then
1621          return False;
1622
1623       --  Unary operators
1624
1625       elsif Num = 1 then
1626          T1 := Etype (First_Formal (New_S));
1627
1628          if Op_Name = Name_Op_Subtract
1629            or else Op_Name = Name_Op_Add
1630            or else Op_Name = Name_Op_Abs
1631          then
1632             return Base_Type (T1) = Base_Type (T)
1633               and then Is_Numeric_Type (T);
1634
1635          elsif Op_Name = Name_Op_Not then
1636             return Base_Type (T1) = Base_Type (T)
1637               and then Valid_Boolean_Arg (Base_Type (T));
1638
1639          else
1640             return False;
1641          end if;
1642
1643       --  Binary operators
1644
1645       else
1646          T1 := Etype (First_Formal (New_S));
1647          T2 := Etype (Next_Formal (First_Formal (New_S)));
1648
1649          if Op_Name =  Name_Op_And or else Op_Name = Name_Op_Or
1650            or else Op_Name = Name_Op_Xor
1651          then
1652             return Base_Type (T1) = Base_Type (T2)
1653               and then Base_Type (T1) = Base_Type (T)
1654               and then Valid_Boolean_Arg (Base_Type (T));
1655
1656          elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
1657             return Base_Type (T1) = Base_Type (T2)
1658               and then not Is_Limited_Type (T1)
1659               and then Is_Boolean_Type (T);
1660
1661          elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
1662            or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
1663          then
1664             return Base_Type (T1) = Base_Type (T2)
1665               and then Valid_Comparison_Arg (T1)
1666               and then Is_Boolean_Type (T);
1667
1668          elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
1669             return Base_Type (T1) = Base_Type (T2)
1670               and then Base_Type (T1) = Base_Type (T)
1671               and then Is_Numeric_Type (T);
1672
1673          --  for division and multiplication, a user-defined function does
1674          --  not match the predefined universal_fixed operation, except in
1675          --  Ada83 mode.
1676
1677          elsif Op_Name = Name_Op_Divide then
1678             return (Base_Type (T1) = Base_Type (T2)
1679               and then Base_Type (T1) = Base_Type (T)
1680               and then Is_Numeric_Type (T)
1681               and then (not Is_Fixed_Point_Type (T)
1682                          or else Ada_83))
1683
1684             --  Mixed_Mode operations on fixed-point types.
1685
1686               or else (Base_Type (T1) = Base_Type (T)
1687                         and then Base_Type (T2) = Base_Type (Standard_Integer)
1688                         and then Is_Fixed_Point_Type (T))
1689
1690             --  A user defined operator can also match (and hide) a mixed
1691             --  operation on universal literals.
1692
1693               or else (Is_Integer_Type (T2)
1694                         and then Is_Floating_Point_Type (T1)
1695                         and then Base_Type (T1) = Base_Type (T));
1696
1697          elsif Op_Name = Name_Op_Multiply then
1698             return (Base_Type (T1) = Base_Type (T2)
1699               and then Base_Type (T1) = Base_Type (T)
1700               and then Is_Numeric_Type (T)
1701               and then (not Is_Fixed_Point_Type (T)
1702                          or else Ada_83))
1703
1704             --  Mixed_Mode operations on fixed-point types.
1705
1706               or else (Base_Type (T1) = Base_Type (T)
1707                         and then Base_Type (T2) = Base_Type (Standard_Integer)
1708                         and then Is_Fixed_Point_Type (T))
1709
1710               or else (Base_Type (T2) = Base_Type (T)
1711                         and then Base_Type (T1) = Base_Type (Standard_Integer)
1712                         and then Is_Fixed_Point_Type (T))
1713
1714               or else (Is_Integer_Type (T2)
1715                         and then Is_Floating_Point_Type (T1)
1716                         and then Base_Type (T1) = Base_Type (T))
1717
1718               or else (Is_Integer_Type (T1)
1719                         and then Is_Floating_Point_Type (T2)
1720                         and then Base_Type (T2) = Base_Type (T));
1721
1722          elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
1723             return Base_Type (T1) = Base_Type (T2)
1724               and then Base_Type (T1) = Base_Type (T)
1725               and then Is_Integer_Type (T);
1726
1727          elsif Op_Name = Name_Op_Expon then
1728             return Base_Type (T1) = Base_Type (T)
1729               and then Is_Numeric_Type (T)
1730               and then Base_Type (T2) = Base_Type (Standard_Integer);
1731
1732          elsif Op_Name = Name_Op_Concat then
1733             return Is_Array_Type (T)
1734               and then (Base_Type (T) = Base_Type (Etype (Op)))
1735               and then (Base_Type (T1) = Base_Type (T)
1736                          or else
1737                         Base_Type (T1) = Base_Type (Component_Type (T)))
1738               and then (Base_Type (T2) = Base_Type (T)
1739                          or else
1740                         Base_Type (T2) = Base_Type (Component_Type (T)));
1741
1742          else
1743             return False;
1744          end if;
1745       end if;
1746    end Operator_Matches_Spec;
1747
1748    -------------------
1749    -- Remove_Interp --
1750    -------------------
1751
1752    procedure Remove_Interp (I : in out Interp_Index) is
1753       II : Interp_Index;
1754
1755    begin
1756       --  Find end of Interp list and copy downward to erase the discarded one
1757
1758       II := I + 1;
1759
1760       while Present (All_Interp.Table (II).Typ) loop
1761          II := II + 1;
1762       end loop;
1763
1764       for J in I + 1 .. II loop
1765          All_Interp.Table (J - 1) := All_Interp.Table (J);
1766       end loop;
1767
1768       --  Back up interp. index to insure that iterator will pick up next
1769       --  available interpretation.
1770
1771       I := I - 1;
1772    end Remove_Interp;
1773
1774    ------------------
1775    -- Save_Interps --
1776    ------------------
1777
1778    procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
1779    begin
1780       if Is_Overloaded (Old_N) then
1781          for Index in 0 .. Interp_Map.Last loop
1782             if Interp_Map.Table (Index).Node = Old_N then
1783                Interp_Map.Table (Index).Node := New_N;
1784                exit;
1785             end if;
1786          end loop;
1787       end if;
1788    end Save_Interps;
1789
1790    -------------------
1791    -- Specific_Type --
1792    -------------------
1793
1794    function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
1795       B1 : constant Entity_Id := Base_Type (T1);
1796       B2 : constant Entity_Id := Base_Type (T2);
1797
1798       function Is_Remote_Access (T : Entity_Id) return Boolean;
1799       --  Check whether T is the equivalent type of a remote access type.
1800       --  If distribution is enabled, T is a legal context for Null.
1801
1802       ----------------------
1803       -- Is_Remote_Access --
1804       ----------------------
1805
1806       function Is_Remote_Access (T : Entity_Id) return Boolean is
1807       begin
1808          return Is_Record_Type (T)
1809            and then (Is_Remote_Call_Interface (T)
1810                       or else Is_Remote_Types (T))
1811            and then Present (Corresponding_Remote_Type (T))
1812            and then Is_Access_Type (Corresponding_Remote_Type (T));
1813       end Is_Remote_Access;
1814
1815    --  Start of processing for Specific_Type
1816
1817    begin
1818       if (T1 = Any_Type or else T2 = Any_Type) then
1819          return Any_Type;
1820       end if;
1821
1822       if B1 = B2 then
1823          return B1;
1824
1825       elsif (T1 = Universal_Integer  and then Is_Integer_Type (T2))
1826         or else (T1 = Universal_Real and then Is_Real_Type (T2))
1827         or else (T1 = Any_Fixed      and then Is_Fixed_Point_Type (T2))
1828       then
1829          return B2;
1830
1831       elsif (T2 = Universal_Integer  and then Is_Integer_Type (T1))
1832         or else (T2 = Universal_Real and then Is_Real_Type (T1))
1833         or else (T2 = Any_Fixed      and then Is_Fixed_Point_Type (T1))
1834       then
1835          return B1;
1836
1837       elsif (T2 = Any_String and then Is_String_Type (T1)) then
1838          return B1;
1839
1840       elsif (T1 = Any_String and then Is_String_Type (T2)) then
1841          return B2;
1842
1843       elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
1844          return B1;
1845
1846       elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
1847          return B2;
1848
1849       elsif (T1 = Any_Access
1850         and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
1851       then
1852          return T2;
1853
1854       elsif (T2 = Any_Access
1855         and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
1856       then
1857          return T1;
1858
1859       elsif (T2 = Any_Composite
1860          and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
1861       then
1862          return T1;
1863
1864       elsif (T1 = Any_Composite
1865          and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
1866       then
1867          return T2;
1868
1869       elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
1870          return T2;
1871
1872       elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
1873          return T1;
1874
1875       --  Special cases for equality operators (all other predefined
1876       --  operators can never apply to tagged types)
1877
1878       elsif Is_Class_Wide_Type (T1)
1879         and then Is_Ancestor (Root_Type (T1), T2)
1880       then
1881          return T1;
1882
1883       elsif Is_Class_Wide_Type (T2)
1884         and then Is_Ancestor (Root_Type (T2), T1)
1885       then
1886          return T2;
1887
1888       elsif (Ekind (B1) = E_Access_Subprogram_Type
1889                or else
1890              Ekind (B1) = E_Access_Protected_Subprogram_Type)
1891         and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
1892         and then Is_Access_Type (T2)
1893       then
1894          return T2;
1895
1896       elsif (Ekind (B2) = E_Access_Subprogram_Type
1897                or else
1898              Ekind (B2) = E_Access_Protected_Subprogram_Type)
1899         and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
1900         and then Is_Access_Type (T1)
1901       then
1902          return T1;
1903
1904       elsif (Ekind (T1) = E_Allocator_Type
1905               or else Ekind (T1) = E_Access_Attribute_Type
1906               or else Ekind (T1) = E_Anonymous_Access_Type)
1907         and then Is_Access_Type (T2)
1908       then
1909          return T2;
1910
1911       elsif (Ekind (T2) = E_Allocator_Type
1912               or else Ekind (T2) = E_Access_Attribute_Type
1913               or else Ekind (T2) = E_Anonymous_Access_Type)
1914         and then Is_Access_Type (T1)
1915       then
1916          return T1;
1917
1918       --  If none of the above cases applies, types are not compatible.
1919
1920       else
1921          return Any_Type;
1922       end if;
1923    end Specific_Type;
1924
1925    ------------------------------
1926    -- Universal_Interpretation --
1927    ------------------------------
1928
1929    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
1930       Index : Interp_Index;
1931       It    : Interp;
1932
1933    begin
1934       --  The argument may be a formal parameter of an operator or subprogram
1935       --  with multiple interpretations, or else an expression for an actual.
1936
1937       if Nkind (Opnd) = N_Defining_Identifier
1938         or else not Is_Overloaded (Opnd)
1939       then
1940          if Etype (Opnd) = Universal_Integer
1941            or else Etype (Opnd) = Universal_Real
1942          then
1943             return Etype (Opnd);
1944          else
1945             return Empty;
1946          end if;
1947
1948       else
1949          Get_First_Interp (Opnd, Index, It);
1950
1951          while Present (It.Typ) loop
1952
1953             if It.Typ = Universal_Integer
1954               or else It.Typ = Universal_Real
1955             then
1956                return It.Typ;
1957             end if;
1958
1959             Get_Next_Interp (Index, It);
1960          end loop;
1961
1962          return Empty;
1963       end if;
1964    end Universal_Interpretation;
1965
1966    -----------------------
1967    -- Valid_Boolean_Arg --
1968    -----------------------
1969
1970    --  In addition to booleans and arrays of booleans, we must include
1971    --  aggregates as valid boolean arguments, because in the first pass
1972    --  of resolution their components are not examined. If it turns out not
1973    --  to be an aggregate of booleans, this will be diagnosed in Resolve.
1974    --  Any_Composite must be checked for prior to the array type checks
1975    --  because Any_Composite does not have any associated indexes.
1976
1977    function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
1978    begin
1979       return Is_Boolean_Type (T)
1980         or else T = Any_Composite
1981         or else (Is_Array_Type (T)
1982                   and then T /= Any_String
1983                   and then Number_Dimensions (T) = 1
1984                   and then Is_Boolean_Type (Component_Type (T))
1985                   and then (not Is_Private_Composite (T)
1986                              or else In_Instance)
1987                   and then (not Is_Limited_Composite (T)
1988                              or else In_Instance))
1989         or else Is_Modular_Integer_Type (T)
1990         or else T = Universal_Integer;
1991    end Valid_Boolean_Arg;
1992
1993    --------------------------
1994    -- Valid_Comparison_Arg --
1995    --------------------------
1996
1997    function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
1998    begin
1999       return Is_Discrete_Type (T)
2000         or else Is_Real_Type (T)
2001         or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
2002                   and then Is_Discrete_Type (Component_Type (T))
2003                   and then (not Is_Private_Composite (T)
2004                              or else In_Instance)
2005                   and then (not Is_Limited_Composite (T)
2006                              or else In_Instance))
2007         or else Is_String_Type (T);
2008    end Valid_Comparison_Arg;
2009
2010    ---------------------
2011    -- Write_Overloads --
2012    ---------------------
2013
2014    procedure Write_Overloads (N : Node_Id) is
2015       I   : Interp_Index;
2016       It  : Interp;
2017       Nam : Entity_Id;
2018
2019    begin
2020       if not Is_Overloaded (N) then
2021          Write_Str ("Non-overloaded entity ");
2022          Write_Eol;
2023          Write_Entity_Info (Entity (N), " ");
2024
2025       else
2026          Get_First_Interp (N, I, It);
2027          Write_Str ("Overloaded entity ");
2028          Write_Eol;
2029          Nam := It.Nam;
2030
2031          while Present (Nam) loop
2032             Write_Entity_Info (Nam,  "      ");
2033             Write_Str ("=================");
2034             Write_Eol;
2035             Get_Next_Interp (I, It);
2036             Nam := It.Nam;
2037          end loop;
2038       end if;
2039    end Write_Overloads;
2040
2041 end Sem_Type;