gcc/ada/sem_ch4.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 4                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Debug;    use Debug;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Util; use Exp_Util;
  32 with Fname;    use Fname;
  33 with Itypes;   use Itypes;
  34 with Lib;      use Lib;
  35 with Lib.Xref; use Lib.Xref;
  36 with Namet;    use Namet;
  37 with Namet.Sp; use Namet.Sp;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Output;   use Output;
  42 with Restrict; use Restrict;
  43 with Rident;   use Rident;
  44 with Sem;      use Sem;
  45 with Sem_Cat;  use Sem_Cat;
  46 with Sem_Ch3;  use Sem_Ch3;
  47 with Sem_Ch6;  use Sem_Ch6;
  48 with Sem_Ch8;  use Sem_Ch8;
  49 with Sem_Disp; use Sem_Disp;
  50 with Sem_Dist; use Sem_Dist;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Util; use Sem_Util;
  54 with Sem_Type; use Sem_Type;
  55 with Stand;    use Stand;
  56 with Sinfo;    use Sinfo;
  57 with Snames;   use Snames;
  58 with Tbuild;   use Tbuild;
  59
  60 package body Sem_Ch4 is
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    procedure Analyze_Concatenation_Rest (N : Node_Id);
  67    --  Does the "rest" of the work of Analyze_Concatenation, after the left
  68    --  operand has been analyzed. See Analyze_Concatenation for details.
  69
  70    procedure Analyze_Expression (N : Node_Id);
  71    --  For expressions that are not names, this is just a call to analyze.
  72    --  If the expression is a name, it may be a call to a parameterless
  73    --  function, and if so must be converted into an explicit call node
  74    --  and analyzed as such. This deproceduring must be done during the first
  75    --  pass of overload resolution, because otherwise a procedure call with
  76    --  overloaded actuals may fail to resolve.
  77
  78    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
  79    --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
  80    --  is an operator name or an expanded name whose selector is an operator
  81    --  name, and one possible interpretation is as a predefined operator.
  82
  83    procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
  84    --  If the prefix of a selected_component is overloaded, the proper
  85    --  interpretation that yields a record type with the proper selector
  86    --  name must be selected.
  87
  88    procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
  89    --  Procedure to analyze a user defined binary operator, which is resolved
  90    --  like a function, but instead of a list of actuals it is presented
  91    --  with the left and right operands of an operator node.
  92
  93    procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
  94    --  Procedure to analyze a user defined unary operator, which is resolved
  95    --  like a function, but instead of a list of actuals, it is presented with
  96    --  the operand of the operator node.
  97
  98    procedure Ambiguous_Operands (N : Node_Id);
  99    --  for equality, membership, and comparison operators with overloaded
 100    --  arguments, list possible interpretations.
 101
 102    procedure Analyze_One_Call
 103       (N          : Node_Id;
 104        Nam        : Entity_Id;
 105        Report     : Boolean;
 106        Success    : out Boolean;
 107        Skip_First : Boolean := False);
 108    --  Check one interpretation of an overloaded subprogram name for
 109    --  compatibility with the types of the actuals in a call. If there is a
 110    --  single interpretation which does not match, post error if Report is
 111    --  set to True.
 112    --
 113    --  Nam is the entity that provides the formals against which the actuals
 114    --  are checked. Nam is either the name of a subprogram, or the internal
 115    --  subprogram type constructed for an access_to_subprogram. If the actuals
 116    --  are compatible with Nam, then Nam is added to the list of candidate
 117    --  interpretations for N, and Success is set to True.
 118    --
 119    --  The flag Skip_First is used when analyzing a call that was rewritten
 120    --  from object notation. In this case the first actual may have to receive
 121    --  an explicit dereference, depending on the first formal of the operation
 122    --  being called. The caller will have verified that the object is legal
 123    --  for the call. If the remaining parameters match, the first parameter
 124    --  will rewritten as a dereference if needed, prior to completing analysis.
 125
 126    procedure Check_Misspelled_Selector
 127      (Prefix : Entity_Id;
 128       Sel    : Node_Id);
 129    --  Give possible misspelling diagnostic if Sel is likely to be
 130    --  a misspelling of one of the selectors of the Prefix.
 131    --  This is called by Analyze_Selected_Component after producing
 132    --  an invalid selector error message.
 133
 134    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
 135    --  Verify that type T is declared in scope S. Used to find intepretations
 136    --  for operators given by expanded names. This is abstracted as a separate
 137    --  function to handle extensions to System, where S is System, but T is
 138    --  declared in the extension.
 139
 140    procedure Find_Arithmetic_Types
 141      (L, R  : Node_Id;
 142       Op_Id : Entity_Id;
 143       N     : Node_Id);
 144    --  L and R are the operands of an arithmetic operator. Find
 145    --  consistent pairs of interpretations for L and R that have a
 146    --  numeric type consistent with the semantics of the operator.
 147
 148    procedure Find_Comparison_Types
 149      (L, R  : Node_Id;
 150       Op_Id : Entity_Id;
 151       N     : Node_Id);
 152    --  L and R are operands of a comparison operator. Find consistent
 153    --  pairs of interpretations for L and R.
 154
 155    procedure Find_Concatenation_Types
 156      (L, R  : Node_Id;
 157       Op_Id : Entity_Id;
 158       N     : Node_Id);
 159    --  For the four varieties of concatenation
 160
 161    procedure Find_Equality_Types
 162      (L, R  : Node_Id;
 163       Op_Id : Entity_Id;
 164       N     : Node_Id);
 165    --  Ditto for equality operators
 166
 167    procedure Find_Boolean_Types
 168      (L, R  : Node_Id;
 169       Op_Id : Entity_Id;
 170       N     : Node_Id);
 171    --  Ditto for binary logical operations
 172
 173    procedure Find_Negation_Types
 174      (R     : Node_Id;
 175       Op_Id : Entity_Id;
 176       N     : Node_Id);
 177    --  Find consistent interpretation for operand of negation operator
 178
 179    procedure Find_Non_Universal_Interpretations
 180      (N     : Node_Id;
 181       R     : Node_Id;
 182       Op_Id : Entity_Id;
 183       T1    : Entity_Id);
 184    --  For equality and comparison operators, the result is always boolean,
 185    --  and the legality of the operation is determined from the visibility
 186    --  of the operand types. If one of the operands has a universal interpre-
 187    --  tation,  the legality check uses some compatible non-universal
 188    --  interpretation of the other operand. N can be an operator node, or
 189    --  a function call whose name is an operator designator.
 190
 191    function Find_Primitive_Operation (N : Node_Id) return Boolean;
 192    --  Find candidate interpretations for the name Obj.Proc when it appears
 193    --  in a subprogram renaming declaration.
 194
 195    procedure Find_Unary_Types
 196      (R     : Node_Id;
 197       Op_Id : Entity_Id;
 198       N     : Node_Id);
 199    --  Unary arithmetic types: plus, minus, abs
 200
 201    procedure Check_Arithmetic_Pair
 202      (T1, T2 : Entity_Id;
 203       Op_Id  : Entity_Id;
 204       N      : Node_Id);
 205    --  Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
 206    --  types for left and right operand. Determine whether they constitute
 207    --  a valid pair for the given operator, and record the corresponding
 208    --  interpretation of the operator node. The node N may be an operator
 209    --  node (the usual case) or a function call whose prefix is an operator
 210    --  designator. In both cases Op_Id is the operator name itself.
 211
 212    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
 213    --  Give detailed information on overloaded call where none of the
 214    --  interpretations match. N is the call node, Nam the designator for
 215    --  the overloaded entity being called.
 216
 217    function Junk_Operand (N : Node_Id) return Boolean;
 218    --  Test for an operand that is an inappropriate entity (e.g. a package
 219    --  name or a label). If so, issue an error message and return True. If
 220    --  the operand is not an inappropriate entity kind, return False.
 221
 222    procedure Operator_Check (N : Node_Id);
 223    --  Verify that an operator has received some valid interpretation. If none
 224    --  was found, determine whether a use clause would make the operation
 225    --  legal. The variable Candidate_Type (defined in Sem_Type) is set for
 226    --  every type compatible with the operator, even if the operator for the
 227    --  type is not directly visible. The routine uses this type to emit a more
 228    --  informative message.
 229
 230    function Process_Implicit_Dereference_Prefix
 231      (E : Entity_Id;
 232       P : Node_Id) return Entity_Id;
 233    --  Called when P is the prefix of an implicit dereference, denoting an
 234    --  object E. The function returns the designated type of the prefix, taking
 235    --  into account that the designated type of an anonymous access type may be
 236    --  a limited view, when the non-limited view is visible.
 237    --  If in semantics only mode (-gnatc or generic), the function also records
 238    --  that the prefix is a reference to E, if any. Normally, such a reference
 239    --  is generated only when the implicit dereference is expanded into an
 240    --  explicit one, but for consistency we must generate the reference when
 241    --  expansion is disabled as well.
 242
 243    procedure Remove_Abstract_Operations (N : Node_Id);
 244    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
 245    --  operation is not a candidate interpretation.
 246
 247    function Try_Indexed_Call
 248      (N          : Node_Id;
 249       Nam        : Entity_Id;
 250       Typ        : Entity_Id;
 251       Skip_First : Boolean) return Boolean;
 252    --  If a function has defaults for all its actuals, a call to it may in fact
 253    --  be an indexing on the result of the call. Try_Indexed_Call attempts the
 254    --  interpretation as an indexing, prior to analysis as a call. If both are
 255    --  possible, the node is overloaded with both interpretations (same symbol
 256    --  but two different types). If the call is written in prefix form, the
 257    --  prefix becomes the first parameter in the call, and only the remaining
 258    --  actuals must be checked for the presence of defaults.
 259
 260    function Try_Indirect_Call
 261      (N   : Node_Id;
 262       Nam : Entity_Id;
 263       Typ : Entity_Id) return Boolean;
 264    --  Similarly, a function F that needs no actuals can return an access to a
 265    --  subprogram, and the call F (X) interpreted as F.all (X). In this case
 266    --  the call may be overloaded with both interpretations.
 267
 268    function Try_Object_Operation (N : Node_Id) return Boolean;
 269    --  Ada 2005 (AI-252): Support the object.operation notation
 270
 271    procedure wpo (T : Entity_Id);
 272    pragma Warnings (Off, wpo);
 273    --  Used for debugging: obtain list of primitive operations even if
 274    --  type is not frozen and dispatch table is not built yet.
 275
 276    ------------------------
 277    -- Ambiguous_Operands --
 278    ------------------------
 279
 280    procedure Ambiguous_Operands (N : Node_Id) is
 281       procedure List_Operand_Interps (Opnd : Node_Id);
 282
 283       --------------------------
 284       -- List_Operand_Interps --
 285       --------------------------
 286
 287       procedure List_Operand_Interps (Opnd : Node_Id) is
 288          Nam   : Node_Id;
 289          Err   : Node_Id := N;
 290
 291       begin
 292          if Is_Overloaded (Opnd) then
 293             if Nkind (Opnd) in N_Op then
 294                Nam := Opnd;
 295             elsif Nkind (Opnd) = N_Function_Call then
 296                Nam := Name (Opnd);
 297             else
 298                return;
 299             end if;
 300
 301          else
 302             return;
 303          end if;
 304
 305          if Opnd = Left_Opnd (N) then
 306             Error_Msg_N
 307               ("\left operand has the following interpretations", N);
 308          else
 309             Error_Msg_N
 310               ("\right operand has the following interpretations", N);
 311             Err := Opnd;
 312          end if;
 313
 314          List_Interps (Nam, Err);
 315       end List_Operand_Interps;
 316
 317    --  Start of processing for Ambiguous_Operands
 318
 319    begin
 320       if Nkind (N) in N_Membership_Test then
 321          Error_Msg_N ("ambiguous operands for membership",  N);
 322
 323       elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
 324          Error_Msg_N ("ambiguous operands for equality",  N);
 325
 326       else
 327          Error_Msg_N ("ambiguous operands for comparison",  N);
 328       end if;
 329
 330       if All_Errors_Mode then
 331          List_Operand_Interps (Left_Opnd  (N));
 332          List_Operand_Interps (Right_Opnd (N));
 333       else
 334          Error_Msg_N ("\use -gnatf switch for details", N);
 335       end if;
 336    end Ambiguous_Operands;
 337
 338    -----------------------
 339    -- Analyze_Aggregate --
 340    -----------------------
 341
 342    --  Most of the analysis of Aggregates requires that the type be known,
 343    --  and is therefore put off until resolution.
 344
 345    procedure Analyze_Aggregate (N : Node_Id) is
 346    begin
 347       if No (Etype (N)) then
 348          Set_Etype (N, Any_Composite);
 349       end if;
 350    end Analyze_Aggregate;
 351
 352    -----------------------
 353    -- Analyze_Allocator --
 354    -----------------------
 355
 356    procedure Analyze_Allocator (N : Node_Id) is
 357       Loc      : constant Source_Ptr := Sloc (N);
 358       Sav_Errs : constant Nat        := Serious_Errors_Detected;
 359       E        : Node_Id             := Expression (N);
 360       Acc_Type : Entity_Id;
 361       Type_Id  : Entity_Id;
 362
 363    begin
 364       --  In accordance with H.4(7), the No_Allocators restriction only applies
 365       --  to user-written allocators.
 366
 367       if Comes_From_Source (N) then
 368          Check_Restriction (No_Allocators, N);
 369       end if;
 370
 371       if Nkind (E) = N_Qualified_Expression then
 372          Acc_Type := Create_Itype (E_Allocator_Type, N);
 373          Set_Etype (Acc_Type, Acc_Type);
 374          Find_Type (Subtype_Mark (E));
 375
 376          --  Analyze the qualified expression, and apply the name resolution
 377          --  rule given in  4.7 (3).
 378
 379          Analyze (E);
 380          Type_Id := Etype (E);
 381          Set_Directly_Designated_Type (Acc_Type, Type_Id);
 382
 383          Resolve (Expression (E), Type_Id);
 384
 385          if Is_Limited_Type (Type_Id)
 386            and then Comes_From_Source (N)
 387            and then not In_Instance_Body
 388          then
 389             if not OK_For_Limited_Init (Expression (E)) then
 390                Error_Msg_N ("initialization not allowed for limited types", N);
 391                Explain_Limited_Type (Type_Id, N);
 392             end if;
 393          end if;
 394
 395          --  A qualified expression requires an exact match of the type,
 396          --  class-wide matching is not allowed.
 397
 398          --  if Is_Class_Wide_Type (Type_Id)
 399          --    and then Base_Type
 400          --       (Etype (Expression (E))) /= Base_Type (Type_Id)
 401          --  then
 402          --     Wrong_Type (Expression (E), Type_Id);
 403          --  end if;
 404
 405          Check_Non_Static_Context (Expression (E));
 406
 407          --  We don't analyze the qualified expression itself because it's
 408          --  part of the allocator
 409
 410          Set_Etype  (E, Type_Id);
 411
 412       --  Case where allocator has a subtype indication
 413
 414       else
 415          declare
 416             Def_Id   : Entity_Id;
 417             Base_Typ : Entity_Id;
 418
 419          begin
 420             --  If the allocator includes a N_Subtype_Indication then a
 421             --  constraint is present, otherwise the node is a subtype mark.
 422             --  Introduce an explicit subtype declaration into the tree
 423             --  defining some anonymous subtype and rewrite the allocator to
 424             --  use this subtype rather than the subtype indication.
 425
 426             --  It is important to introduce the explicit subtype declaration
 427             --  so that the bounds of the subtype indication are attached to
 428             --  the tree in case the allocator is inside a generic unit.
 429
 430             if Nkind (E) = N_Subtype_Indication then
 431
 432                --  A constraint is only allowed for a composite type in Ada
 433                --  95. In Ada 83, a constraint is also allowed for an
 434                --  access-to-composite type, but the constraint is ignored.
 435
 436                Find_Type (Subtype_Mark (E));
 437                Base_Typ := Entity (Subtype_Mark (E));
 438
 439                if Is_Elementary_Type (Base_Typ) then
 440                   if not (Ada_Version = Ada_83
 441                            and then Is_Access_Type (Base_Typ))
 442                   then
 443                      Error_Msg_N ("constraint not allowed here", E);
 444
 445                      if Nkind (Constraint (E)) =
 446                        N_Index_Or_Discriminant_Constraint
 447                      then
 448                         Error_Msg_N
 449                           ("\if qualified expression was meant, " &
 450                               "use apostrophe", Constraint (E));
 451                      end if;
 452                   end if;
 453
 454                   --  Get rid of the bogus constraint:
 455
 456                   Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
 457                   Analyze_Allocator (N);
 458                   return;
 459
 460                --  Ada 2005, AI-363: if the designated type has a constrained
 461                --  partial view, it cannot receive a discriminant constraint,
 462                --  and the allocated object is unconstrained.
 463
 464                elsif Ada_Version >= Ada_05
 465                  and then Has_Constrained_Partial_View (Base_Typ)
 466                then
 467                   Error_Msg_N
 468                     ("constraint no allowed when type " &
 469                       "has a constrained partial view", Constraint (E));
 470                end if;
 471
 472                if Expander_Active then
 473                   Def_Id :=
 474                     Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 475
 476                   Insert_Action (E,
 477                     Make_Subtype_Declaration (Loc,
 478                       Defining_Identifier => Def_Id,
 479                       Subtype_Indication  => Relocate_Node (E)));
 480
 481                   if Sav_Errs /= Serious_Errors_Detected
 482                     and then Nkind (Constraint (E)) =
 483                                N_Index_Or_Discriminant_Constraint
 484                   then
 485                      Error_Msg_N
 486                        ("if qualified expression was meant, " &
 487                            "use apostrophe!", Constraint (E));
 488                   end if;
 489
 490                   E := New_Occurrence_Of (Def_Id, Loc);
 491                   Rewrite (Expression (N), E);
 492                end if;
 493             end if;
 494
 495             Type_Id := Process_Subtype (E, N);
 496             Acc_Type := Create_Itype (E_Allocator_Type, N);
 497             Set_Etype                    (Acc_Type, Acc_Type);
 498             Set_Directly_Designated_Type (Acc_Type, Type_Id);
 499             Check_Fully_Declared (Type_Id, N);
 500
 501             --  Ada 2005 (AI-231)
 502
 503             if Can_Never_Be_Null (Type_Id) then
 504                Error_Msg_N ("(Ada 2005) qualified expression required",
 505                             Expression (N));
 506             end if;
 507
 508             --  Check restriction against dynamically allocated protected
 509             --  objects. Note that when limited aggregates are supported,
 510             --  a similar test should be applied to an allocator with a
 511             --  qualified expression ???
 512
 513             if Is_Protected_Type (Type_Id) then
 514                Check_Restriction (No_Protected_Type_Allocators, N);
 515             end if;
 516
 517             --  Check for missing initialization. Skip this check if we already
 518             --  had errors on analyzing the allocator, since in that case these
 519             --  are probably cascaded errors.
 520
 521             if Is_Indefinite_Subtype (Type_Id)
 522               and then Serious_Errors_Detected = Sav_Errs
 523             then
 524                if Is_Class_Wide_Type (Type_Id) then
 525                   Error_Msg_N
 526                     ("initialization required in class-wide allocation", N);
 527                else
 528                   if Ada_Version < Ada_05
 529                     and then Is_Limited_Type (Type_Id)
 530                   then
 531                      Error_Msg_N ("unconstrained allocation not allowed", N);
 532
 533                      if Is_Array_Type (Type_Id) then
 534                         Error_Msg_N
 535                           ("\constraint with array bounds required", N);
 536
 537                      elsif Has_Unknown_Discriminants (Type_Id) then
 538                         null;
 539
 540                      else pragma Assert (Has_Discriminants (Type_Id));
 541                         Error_Msg_N
 542                           ("\constraint with discriminant values required", N);
 543                      end if;
 544
 545                   --  Limited Ada 2005 and general non-limited case
 546
 547                   else
 548                      Error_Msg_N
 549                        ("uninitialized unconstrained allocation not allowed",
 550                         N);
 551
 552                      if Is_Array_Type (Type_Id) then
 553                         Error_Msg_N
 554                           ("\qualified expression or constraint with " &
 555                            "array bounds required", N);
 556
 557                      elsif Has_Unknown_Discriminants (Type_Id) then
 558                         Error_Msg_N ("\qualified expression required", N);
 559
 560                      else pragma Assert (Has_Discriminants (Type_Id));
 561                         Error_Msg_N
 562                           ("\qualified expression or constraint with " &
 563                            "discriminant values required", N);
 564                      end if;
 565                   end if;
 566                end if;
 567             end if;
 568          end;
 569       end if;
 570
 571       if Is_Abstract_Type (Type_Id) then
 572          Error_Msg_N ("cannot allocate abstract object", E);
 573       end if;
 574
 575       if Has_Task (Designated_Type (Acc_Type)) then
 576          Check_Restriction (No_Tasking, N);
 577          Check_Restriction (Max_Tasks, N);
 578          Check_Restriction (No_Task_Allocators, N);
 579       end if;
 580
 581       --  If the No_Streams restriction is set, check that the type of the
 582       --  object is not, and does not contain, any subtype derived from
 583       --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
 584       --  Has_Stream just for efficiency reasons. There is no point in
 585       --  spending time on a Has_Stream check if the restriction is not set.
 586
 587       if Restrictions.Set (No_Streams) then
 588          if Has_Stream (Designated_Type (Acc_Type)) then
 589             Check_Restriction (No_Streams, N);
 590          end if;
 591       end if;
 592
 593       Set_Etype (N, Acc_Type);
 594
 595       if not Is_Library_Level_Entity (Acc_Type) then
 596          Check_Restriction (No_Local_Allocators, N);
 597       end if;
 598
 599       if Serious_Errors_Detected > Sav_Errs then
 600          Set_Error_Posted (N);
 601          Set_Etype (N, Any_Type);
 602       end if;
 603    end Analyze_Allocator;
 604
 605    ---------------------------
 606    -- Analyze_Arithmetic_Op --
 607    ---------------------------
 608
 609    procedure Analyze_Arithmetic_Op (N : Node_Id) is
 610       L     : constant Node_Id := Left_Opnd (N);
 611       R     : constant Node_Id := Right_Opnd (N);
 612       Op_Id : Entity_Id;
 613
 614    begin
 615       Candidate_Type := Empty;
 616       Analyze_Expression (L);
 617       Analyze_Expression (R);
 618
 619       --  If the entity is already set, the node is the instantiation of a
 620       --  generic node with a non-local reference, or was manufactured by a
 621       --  call to Make_Op_xxx. In either case the entity is known to be valid,
 622       --  and we do not need to collect interpretations, instead we just get
 623       --  the single possible interpretation.
 624
 625       Op_Id := Entity (N);
 626
 627       if Present (Op_Id) then
 628          if Ekind (Op_Id) = E_Operator then
 629
 630             if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem)
 631               and then Treat_Fixed_As_Integer (N)
 632             then
 633                null;
 634             else
 635                Set_Etype (N, Any_Type);
 636                Find_Arithmetic_Types (L, R, Op_Id, N);
 637             end if;
 638
 639          else
 640             Set_Etype (N, Any_Type);
 641             Add_One_Interp (N, Op_Id, Etype (Op_Id));
 642          end if;
 643
 644       --  Entity is not already set, so we do need to collect interpretations
 645
 646       else
 647          Op_Id := Get_Name_Entity_Id (Chars (N));
 648          Set_Etype (N, Any_Type);
 649
 650          while Present (Op_Id) loop
 651             if Ekind (Op_Id) = E_Operator
 652               and then Present (Next_Entity (First_Entity (Op_Id)))
 653             then
 654                Find_Arithmetic_Types (L, R, Op_Id, N);
 655
 656             --  The following may seem superfluous, because an operator cannot
 657             --  be generic, but this ignores the cleverness of the author of
 658             --  ACVC bc1013a.
 659
 660             elsif Is_Overloadable (Op_Id) then
 661                Analyze_User_Defined_Binary_Op (N, Op_Id);
 662             end if;
 663
 664             Op_Id := Homonym (Op_Id);
 665          end loop;
 666       end if;
 667
 668       Operator_Check (N);
 669    end Analyze_Arithmetic_Op;
 670
 671    ------------------
 672    -- Analyze_Call --
 673    ------------------
 674
 675    --  Function, procedure, and entry calls are checked here. The Name in
 676    --  the call may be overloaded. The actuals have been analyzed and may
 677    --  themselves be overloaded. On exit from this procedure, the node N
 678    --  may have zero, one or more interpretations. In the first case an
 679    --  error message is produced. In the last case, the node is flagged
 680    --  as overloaded and the interpretations are collected in All_Interp.
 681
 682    --  If the name is an Access_To_Subprogram, it cannot be overloaded, but
 683    --  the type-checking is similar to that of other calls.
 684
 685    procedure Analyze_Call (N : Node_Id) is
 686       Actuals : constant List_Id := Parameter_Associations (N);
 687       Nam     : Node_Id          := Name (N);
 688       X       : Interp_Index;
 689       It      : Interp;
 690       Nam_Ent : Entity_Id;
 691       Success : Boolean := False;
 692
 693       function Name_Denotes_Function return Boolean;
 694       --  If the type of the name is an access to subprogram, this may be
 695       --  the type of a name, or the return type of the function being called.
 696       --  If the name is not an entity then it can denote a protected function.
 697       --  Until we distinguish Etype from Return_Type, we must use this
 698       --  routine to resolve the meaning of the name in the call.
 699
 700       ---------------------------
 701       -- Name_Denotes_Function --
 702       ---------------------------
 703
 704       function Name_Denotes_Function return Boolean is
 705       begin
 706          if Is_Entity_Name (Nam) then
 707             return Ekind (Entity (Nam)) = E_Function;
 708
 709          elsif Nkind (Nam) = N_Selected_Component then
 710             return Ekind (Entity (Selector_Name (Nam))) = E_Function;
 711
 712          else
 713             return False;
 714          end if;
 715       end Name_Denotes_Function;
 716
 717    --  Start of processing for Analyze_Call
 718
 719    begin
 720       --  Initialize the type of the result of the call to the error type,
 721       --  which will be reset if the type is successfully resolved.
 722
 723       Set_Etype (N, Any_Type);
 724
 725       if not Is_Overloaded (Nam) then
 726
 727          --  Only one interpretation to check
 728
 729          if Ekind (Etype (Nam)) = E_Subprogram_Type then
 730             Nam_Ent := Etype (Nam);
 731
 732          --  If the prefix is an access_to_subprogram, this may be an indirect
 733          --  call. This is the case if the name in the call is not an entity
 734          --  name, or if it is a function name in the context of a procedure
 735          --  call. In this latter case, we have a call to a parameterless
 736          --  function that returns a pointer_to_procedure which is the entity
 737          --  being called.
 738
 739          elsif Is_Access_Type (Etype (Nam))
 740            and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
 741            and then
 742              (not Name_Denotes_Function
 743                 or else Nkind (N) = N_Procedure_Call_Statement)
 744          then
 745             Nam_Ent := Designated_Type (Etype (Nam));
 746             Insert_Explicit_Dereference (Nam);
 747
 748          --  Selected component case. Simple entry or protected operation,
 749          --  where the entry name is given by the selector name.
 750
 751          elsif Nkind (Nam) = N_Selected_Component then
 752             Nam_Ent := Entity (Selector_Name (Nam));
 753
 754             if Ekind (Nam_Ent) /= E_Entry
 755               and then Ekind (Nam_Ent) /= E_Entry_Family
 756               and then Ekind (Nam_Ent) /= E_Function
 757               and then Ekind (Nam_Ent) /= E_Procedure
 758             then
 759                Error_Msg_N ("name in call is not a callable entity", Nam);
 760                Set_Etype (N, Any_Type);
 761                return;
 762             end if;
 763
 764          --  If the name is an Indexed component, it can be a call to a member
 765          --  of an entry family. The prefix must be a selected component whose
 766          --  selector is the entry. Analyze_Procedure_Call normalizes several
 767          --  kinds of call into this form.
 768
 769          elsif Nkind (Nam) = N_Indexed_Component then
 770             if Nkind (Prefix (Nam)) = N_Selected_Component then
 771                Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
 772             else
 773                Error_Msg_N ("name in call is not a callable entity", Nam);
 774                Set_Etype (N, Any_Type);
 775                return;
 776             end if;
 777
 778          elsif not Is_Entity_Name (Nam) then
 779             Error_Msg_N ("name in call is not a callable entity", Nam);
 780             Set_Etype (N, Any_Type);
 781             return;
 782
 783          else
 784             Nam_Ent := Entity (Nam);
 785
 786             --  If no interpretations, give error message
 787
 788             if not Is_Overloadable (Nam_Ent) then
 789                declare
 790                   L : constant Boolean   := Is_List_Member (N);
 791                   K : constant Node_Kind := Nkind (Parent (N));
 792
 793                begin
 794                   --  If the node is in a list whose parent is not an
 795                   --  expression then it must be an attempted procedure call.
 796
 797                   if L and then K not in N_Subexpr then
 798                      if Ekind (Entity (Nam)) = E_Generic_Procedure then
 799                         Error_Msg_NE
 800                           ("must instantiate generic procedure& before call",
 801                            Nam, Entity (Nam));
 802                      else
 803                         Error_Msg_N
 804                           ("procedure or entry name expected", Nam);
 805                      end if;
 806
 807                   --  Check for tasking cases where only an entry call will do
 808
 809                   elsif not L
 810                     and then Nkind_In (K, N_Entry_Call_Alternative,
 811                                           N_Triggering_Alternative)
 812                   then
 813                      Error_Msg_N ("entry name expected", Nam);
 814
 815                   --  Otherwise give general error message
 816
 817                   else
 818                      Error_Msg_N ("invalid prefix in call", Nam);
 819                   end if;
 820
 821                   return;
 822                end;
 823             end if;
 824          end if;
 825
 826          Analyze_One_Call (N, Nam_Ent, True, Success);
 827
 828          --  If this is an indirect call, the return type of the access_to
 829          --  subprogram may be an incomplete type. At the point of the call,
 830          --  use the full type if available, and at the same time update
 831          --  the return type of the access_to_subprogram.
 832
 833          if Success
 834            and then Nkind (Nam) = N_Explicit_Dereference
 835            and then Ekind (Etype (N)) = E_Incomplete_Type
 836            and then Present (Full_View (Etype (N)))
 837          then
 838             Set_Etype (N, Full_View (Etype (N)));
 839             Set_Etype (Nam_Ent, Etype (N));
 840          end if;
 841
 842       else
 843          --  An overloaded selected component must denote overloaded
 844          --  operations of a concurrent type. The interpretations are
 845          --  attached to the simple name of those operations.
 846
 847          if Nkind (Nam) = N_Selected_Component then
 848             Nam := Selector_Name (Nam);
 849          end if;
 850
 851          Get_First_Interp (Nam, X, It);
 852
 853          while Present (It.Nam) loop
 854             Nam_Ent := It.Nam;
 855
 856             --  Name may be call that returns an access to subprogram, or more
 857             --  generally an overloaded expression one of whose interpretations
 858             --  yields an access to subprogram. If the name is an entity, we
 859             --  do not dereference, because the node is a call that returns
 860             --  the access type: note difference between f(x), where the call
 861             --  may return an access subprogram type, and f(x)(y), where the
 862             --  type returned by the call to f is implicitly dereferenced to
 863             --  analyze the outer call.
 864
 865             if Is_Access_Type (Nam_Ent) then
 866                Nam_Ent := Designated_Type (Nam_Ent);
 867
 868             elsif Is_Access_Type (Etype (Nam_Ent))
 869               and then not Is_Entity_Name (Nam)
 870               and then Ekind (Designated_Type (Etype (Nam_Ent)))
 871                                                           = E_Subprogram_Type
 872             then
 873                Nam_Ent := Designated_Type (Etype (Nam_Ent));
 874             end if;
 875
 876             Analyze_One_Call (N, Nam_Ent, False, Success);
 877
 878             --  If the interpretation succeeds, mark the proper type of the
 879             --  prefix (any valid candidate will do). If not, remove the
 880             --  candidate interpretation. This only needs to be done for
 881             --  overloaded protected operations, for other entities disambi-
 882             --  guation is done directly in Resolve.
 883
 884             if Success then
 885                Set_Etype (Nam, It.Typ);
 886
 887             elsif Nkind_In (Name (N), N_Selected_Component,
 888                                       N_Function_Call)
 889             then
 890                Remove_Interp (X);
 891             end if;
 892
 893             Get_Next_Interp (X, It);
 894          end loop;
 895
 896          --  If the name is the result of a function call, it can only
 897          --  be a call to a function returning an access to subprogram.
 898          --  Insert explicit dereference.
 899
 900          if Nkind (Nam) = N_Function_Call then
 901             Insert_Explicit_Dereference (Nam);
 902          end if;
 903
 904          if Etype (N) = Any_Type then
 905
 906             --  None of the interpretations is compatible with the actuals
 907
 908             Diagnose_Call (N, Nam);
 909
 910             --  Special checks for uninstantiated put routines
 911
 912             if Nkind (N) = N_Procedure_Call_Statement
 913               and then Is_Entity_Name (Nam)
 914               and then Chars (Nam) = Name_Put
 915               and then List_Length (Actuals) = 1
 916             then
 917                declare
 918                   Arg : constant Node_Id := First (Actuals);
 919                   Typ : Entity_Id;
 920
 921                begin
 922                   if Nkind (Arg) = N_Parameter_Association then
 923                      Typ := Etype (Explicit_Actual_Parameter (Arg));
 924                   else
 925                      Typ := Etype (Arg);
 926                   end if;
 927
 928                   if Is_Signed_Integer_Type (Typ) then
 929                      Error_Msg_N
 930                        ("possible missing instantiation of " &
 931                           "'Text_'I'O.'Integer_'I'O!", Nam);
 932
 933                   elsif Is_Modular_Integer_Type (Typ) then
 934                      Error_Msg_N
 935                        ("possible missing instantiation of " &
 936                           "'Text_'I'O.'Modular_'I'O!", Nam);
 937
 938                   elsif Is_Floating_Point_Type (Typ) then
 939                      Error_Msg_N
 940                        ("possible missing instantiation of " &
 941                           "'Text_'I'O.'Float_'I'O!", Nam);
 942
 943                   elsif Is_Ordinary_Fixed_Point_Type (Typ) then
 944                      Error_Msg_N
 945                        ("possible missing instantiation of " &
 946                           "'Text_'I'O.'Fixed_'I'O!", Nam);
 947
 948                   elsif Is_Decimal_Fixed_Point_Type (Typ) then
 949                      Error_Msg_N
 950                        ("possible missing instantiation of " &
 951                           "'Text_'I'O.'Decimal_'I'O!", Nam);
 952
 953                   elsif Is_Enumeration_Type (Typ) then
 954                      Error_Msg_N
 955                        ("possible missing instantiation of " &
 956                           "'Text_'I'O.'Enumeration_'I'O!", Nam);
 957                   end if;
 958                end;
 959             end if;
 960
 961          elsif not Is_Overloaded (N)
 962            and then Is_Entity_Name (Nam)
 963          then
 964             --  Resolution yields a single interpretation. Verify that the
 965             --  reference has capitalization consistent with the declaration.
 966
 967             Set_Entity_With_Style_Check (Nam, Entity (Nam));
 968             Generate_Reference (Entity (Nam), Nam);
 969
 970             Set_Etype (Nam, Etype (Entity (Nam)));
 971          else
 972             Remove_Abstract_Operations (N);
 973          end if;
 974
 975          End_Interp_List;
 976       end if;
 977    end Analyze_Call;
 978
 979    ---------------------------
 980    -- Analyze_Comparison_Op --
 981    ---------------------------
 982
 983    procedure Analyze_Comparison_Op (N : Node_Id) is
 984       L     : constant Node_Id := Left_Opnd (N);
 985       R     : constant Node_Id := Right_Opnd (N);
 986       Op_Id : Entity_Id        := Entity (N);
 987
 988    begin
 989       Set_Etype (N, Any_Type);
 990       Candidate_Type := Empty;
 991
 992       Analyze_Expression (L);
 993       Analyze_Expression (R);
 994
 995       if Present (Op_Id) then
 996          if Ekind (Op_Id) = E_Operator then
 997             Find_Comparison_Types (L, R, Op_Id, N);
 998          else
 999             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1000          end if;
1001
1002          if Is_Overloaded (L) then
1003             Set_Etype (L, Intersect_Types (L, R));
1004          end if;
1005
1006       else
1007          Op_Id := Get_Name_Entity_Id (Chars (N));
1008          while Present (Op_Id) loop
1009             if Ekind (Op_Id) = E_Operator then
1010                Find_Comparison_Types (L, R, Op_Id, N);
1011             else
1012                Analyze_User_Defined_Binary_Op (N, Op_Id);
1013             end if;
1014
1015             Op_Id := Homonym (Op_Id);
1016          end loop;
1017       end if;
1018
1019       Operator_Check (N);
1020    end Analyze_Comparison_Op;
1021
1022    ---------------------------
1023    -- Analyze_Concatenation --
1024    ---------------------------
1025
1026    procedure Analyze_Concatenation (N : Node_Id) is
1027
1028       --  We wish to avoid deep recursion, because concatenations are often
1029       --  deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1030       --  operands nonrecursively until we find something that is not a
1031       --  concatenation (A in this case), or has already been analyzed. We
1032       --  analyze that, and then walk back up the tree following Parent
1033       --  pointers, calling Analyze_Concatenation_Rest to do the rest of the
1034       --  work at each level. The Parent pointers allow us to avoid recursion,
1035       --  and thus avoid running out of memory.
1036
1037       NN : Node_Id := N;
1038       L  : Node_Id;
1039
1040    begin
1041       Candidate_Type := Empty;
1042
1043       --  The following code is equivalent to:
1044
1045       --    Set_Etype (N, Any_Type);
1046       --    Analyze_Expression (Left_Opnd (N));
1047       --    Analyze_Concatenation_Rest (N);
1048
1049       --  where the Analyze_Expression call recurses back here if the left
1050       --  operand is a concatenation.
1051
1052       --  Walk down left operands
1053
1054       loop
1055          Set_Etype (NN, Any_Type);
1056          L := Left_Opnd (NN);
1057          exit when Nkind (L) /= N_Op_Concat or else Analyzed (L);
1058          NN := L;
1059       end loop;
1060
1061       --  Now (given the above example) NN is A&B and L is A
1062
1063       --  First analyze L ...
1064
1065       Analyze_Expression (L);
1066
1067       --  ... then walk NN back up until we reach N (where we started), calling
1068       --  Analyze_Concatenation_Rest along the way.
1069
1070       loop
1071          Analyze_Concatenation_Rest (NN);
1072          exit when NN = N;
1073          NN := Parent (NN);
1074       end loop;
1075    end Analyze_Concatenation;
1076
1077    --------------------------------
1078    -- Analyze_Concatenation_Rest --
1079    --------------------------------
1080
1081    --  If the only one-dimensional array type in scope is String,
1082    --  this is the resulting type of the operation. Otherwise there
1083    --  will be a concatenation operation defined for each user-defined
1084    --  one-dimensional array.
1085
1086    procedure Analyze_Concatenation_Rest (N : Node_Id) is
1087       L     : constant Node_Id := Left_Opnd (N);
1088       R     : constant Node_Id := Right_Opnd (N);
1089       Op_Id : Entity_Id        := Entity (N);
1090       LT    : Entity_Id;
1091       RT    : Entity_Id;
1092
1093    begin
1094       Analyze_Expression (R);
1095
1096       --  If the entity is present, the node appears in an instance, and
1097       --  denotes a predefined concatenation operation. The resulting type is
1098       --  obtained from the arguments when possible. If the arguments are
1099       --  aggregates, the array type and the concatenation type must be
1100       --  visible.
1101
1102       if Present (Op_Id) then
1103          if Ekind (Op_Id) = E_Operator then
1104
1105             LT := Base_Type (Etype (L));
1106             RT := Base_Type (Etype (R));
1107
1108             if Is_Array_Type (LT)
1109               and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
1110             then
1111                Add_One_Interp (N, Op_Id, LT);
1112
1113             elsif Is_Array_Type (RT)
1114               and then LT = Base_Type (Component_Type (RT))
1115             then
1116                Add_One_Interp (N, Op_Id, RT);
1117
1118             --  If one operand is a string type or a user-defined array type,
1119             --  and the other is a literal, result is of the specific type.
1120
1121             elsif
1122               (Root_Type (LT) = Standard_String
1123                  or else Scope (LT) /= Standard_Standard)
1124               and then Etype (R) = Any_String
1125             then
1126                Add_One_Interp (N, Op_Id, LT);
1127
1128             elsif
1129               (Root_Type (RT) = Standard_String
1130                  or else Scope (RT) /= Standard_Standard)
1131               and then Etype (L) = Any_String
1132             then
1133                Add_One_Interp (N, Op_Id, RT);
1134
1135             elsif not Is_Generic_Type (Etype (Op_Id)) then
1136                Add_One_Interp (N, Op_Id, Etype (Op_Id));
1137
1138             else
1139                --  Type and its operations must be visible
1140
1141                Set_Entity (N, Empty);
1142                Analyze_Concatenation (N);
1143             end if;
1144
1145          else
1146             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1147          end if;
1148
1149       else
1150          Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
1151          while Present (Op_Id) loop
1152             if Ekind (Op_Id) = E_Operator then
1153
1154                --  Do not consider operators declared in dead code, they can
1155                --  not be part of the resolution.
1156
1157                if Is_Eliminated (Op_Id) then
1158                   null;
1159                else
1160                   Find_Concatenation_Types (L, R, Op_Id, N);
1161                end if;
1162
1163             else
1164                Analyze_User_Defined_Binary_Op (N, Op_Id);
1165             end if;
1166
1167             Op_Id := Homonym (Op_Id);
1168          end loop;
1169       end if;
1170
1171       Operator_Check (N);
1172    end Analyze_Concatenation_Rest;
1173
1174    ------------------------------------
1175    -- Analyze_Conditional_Expression --
1176    ------------------------------------
1177
1178    procedure Analyze_Conditional_Expression (N : Node_Id) is
1179       Condition : constant Node_Id := First (Expressions (N));
1180       Then_Expr : constant Node_Id := Next (Condition);
1181       Else_Expr : constant Node_Id := Next (Then_Expr);
1182    begin
1183       Analyze_Expression (Condition);
1184       Analyze_Expression (Then_Expr);
1185       Analyze_Expression (Else_Expr);
1186       Set_Etype (N, Etype (Then_Expr));
1187    end Analyze_Conditional_Expression;
1188
1189    -------------------------
1190    -- Analyze_Equality_Op --
1191    -------------------------
1192
1193    procedure Analyze_Equality_Op (N : Node_Id) is
1194       Loc   : constant Source_Ptr := Sloc (N);
1195       L     : constant Node_Id := Left_Opnd (N);
1196       R     : constant Node_Id := Right_Opnd (N);
1197       Op_Id : Entity_Id;
1198
1199    begin
1200       Set_Etype (N, Any_Type);
1201       Candidate_Type := Empty;
1202
1203       Analyze_Expression (L);
1204       Analyze_Expression (R);
1205
1206       --  If the entity is set, the node is a generic instance with a non-local
1207       --  reference to the predefined operator or to a user-defined function.
1208       --  It can also be an inequality that is expanded into the negation of a
1209       --  call to a user-defined equality operator.
1210
1211       --  For the predefined case, the result is Boolean, regardless of the
1212       --  type of the  operands. The operands may even be limited, if they are
1213       --  generic actuals. If they are overloaded, label the left argument with
1214       --  the common type that must be present, or with the type of the formal
1215       --  of the user-defined function.
1216
1217       if Present (Entity (N)) then
1218          Op_Id := Entity (N);
1219
1220          if Ekind (Op_Id) = E_Operator then
1221             Add_One_Interp (N, Op_Id, Standard_Boolean);
1222          else
1223             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1224          end if;
1225
1226          if Is_Overloaded (L) then
1227             if Ekind (Op_Id) = E_Operator then
1228                Set_Etype (L, Intersect_Types (L, R));
1229             else
1230                Set_Etype (L, Etype (First_Formal (Op_Id)));
1231             end if;
1232          end if;
1233
1234       else
1235          Op_Id := Get_Name_Entity_Id (Chars (N));
1236          while Present (Op_Id) loop
1237             if Ekind (Op_Id) = E_Operator then
1238                Find_Equality_Types (L, R, Op_Id, N);
1239             else
1240                Analyze_User_Defined_Binary_Op (N, Op_Id);
1241             end if;
1242
1243             Op_Id := Homonym (Op_Id);
1244          end loop;
1245       end if;
1246
1247       --  If there was no match, and the operator is inequality, this may
1248       --  be a case where inequality has not been made explicit, as for
1249       --  tagged types. Analyze the node as the negation of an equality
1250       --  operation. This cannot be done earlier, because before analysis
1251       --  we cannot rule out the presence of an explicit inequality.
1252
1253       if Etype (N) = Any_Type
1254         and then Nkind (N) = N_Op_Ne
1255       then
1256          Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
1257          while Present (Op_Id) loop
1258             if Ekind (Op_Id) = E_Operator then
1259                Find_Equality_Types (L, R, Op_Id, N);
1260             else
1261                Analyze_User_Defined_Binary_Op (N, Op_Id);
1262             end if;
1263
1264             Op_Id := Homonym (Op_Id);
1265          end loop;
1266
1267          if Etype (N) /= Any_Type then
1268             Op_Id := Entity (N);
1269
1270             Rewrite (N,
1271               Make_Op_Not (Loc,
1272                 Right_Opnd =>
1273                   Make_Op_Eq (Loc,
1274                     Left_Opnd  => Left_Opnd (N),
1275                     Right_Opnd => Right_Opnd (N))));
1276
1277             Set_Entity (Right_Opnd (N), Op_Id);
1278             Analyze (N);
1279          end if;
1280       end if;
1281
1282       Operator_Check (N);
1283    end Analyze_Equality_Op;
1284
1285    ----------------------------------
1286    -- Analyze_Explicit_Dereference --
1287    ----------------------------------
1288
1289    procedure Analyze_Explicit_Dereference (N : Node_Id) is
1290       Loc   : constant Source_Ptr := Sloc (N);
1291       P     : constant Node_Id := Prefix (N);
1292       T     : Entity_Id;
1293       I     : Interp_Index;
1294       It    : Interp;
1295       New_N : Node_Id;
1296
1297       function Is_Function_Type return Boolean;
1298       --  Check whether node may be interpreted as an implicit function call
1299
1300       ----------------------
1301       -- Is_Function_Type --
1302       ----------------------
1303
1304       function Is_Function_Type return Boolean is
1305          I  : Interp_Index;
1306          It : Interp;
1307
1308       begin
1309          if not Is_Overloaded (N) then
1310             return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
1311               and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
1312
1313          else
1314             Get_First_Interp (N, I, It);
1315             while Present (It.Nam) loop
1316                if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
1317                  or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
1318                then
1319                   return False;
1320                end if;
1321
1322                Get_Next_Interp (I, It);
1323             end loop;
1324
1325             return True;
1326          end if;
1327       end Is_Function_Type;
1328
1329    --  Start of processing for Analyze_Explicit_Dereference
1330
1331    begin
1332       Analyze (P);
1333       Set_Etype (N, Any_Type);
1334
1335       --  Test for remote access to subprogram type, and if so return
1336       --  after rewriting the original tree.
1337
1338       if Remote_AST_E_Dereference (P) then
1339          return;
1340       end if;
1341
1342       --  Normal processing for other than remote access to subprogram type
1343
1344       if not Is_Overloaded (P) then
1345          if Is_Access_Type (Etype (P)) then
1346
1347             --  Set the Etype. We need to go thru Is_For_Access_Subtypes to
1348             --  avoid other problems caused by the Private_Subtype and it is
1349             --  safe to go to the Base_Type because this is the same as
1350             --  converting the access value to its Base_Type.
1351
1352             declare
1353                DT : Entity_Id := Designated_Type (Etype (P));
1354
1355             begin
1356                if Ekind (DT) = E_Private_Subtype
1357                  and then Is_For_Access_Subtype (DT)
1358                then
1359                   DT := Base_Type (DT);
1360                end if;
1361
1362                --  An explicit dereference is a legal occurrence of an
1363                --  incomplete type imported through a limited_with clause,
1364                --  if the full view is visible.
1365
1366                if From_With_Type (DT)
1367                  and then not From_With_Type (Scope (DT))
1368                  and then
1369                    (Is_Immediately_Visible (Scope (DT))
1370                      or else
1371                        (Is_Child_Unit (Scope (DT))
1372                           and then Is_Visible_Child_Unit (Scope (DT))))
1373                then
1374                   Set_Etype (N, Available_View (DT));
1375
1376                else
1377                   Set_Etype (N, DT);
1378                end if;
1379             end;
1380
1381          elsif Etype (P) /= Any_Type then
1382             Error_Msg_N ("prefix of dereference must be an access type", N);
1383             return;
1384          end if;
1385
1386       else
1387          Get_First_Interp (P, I, It);
1388          while Present (It.Nam) loop
1389             T := It.Typ;
1390
1391             if Is_Access_Type (T) then
1392                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
1393             end if;
1394
1395             Get_Next_Interp (I, It);
1396          end loop;
1397
1398          --  Error if no interpretation of the prefix has an access type
1399
1400          if Etype (N) = Any_Type then
1401             Error_Msg_N
1402               ("access type required in prefix of explicit dereference", P);
1403             Set_Etype (N, Any_Type);
1404             return;
1405          end if;
1406       end if;
1407
1408       if Is_Function_Type
1409         and then Nkind (Parent (N)) /= N_Indexed_Component
1410
1411         and then (Nkind (Parent (N)) /= N_Function_Call
1412                    or else N /= Name (Parent (N)))
1413
1414         and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
1415                    or else N /= Name (Parent (N)))
1416
1417         and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
1418         and then (Nkind (Parent (N)) /= N_Attribute_Reference
1419                     or else
1420                       (Attribute_Name (Parent (N)) /= Name_Address
1421                         and then
1422                        Attribute_Name (Parent (N)) /= Name_Access))
1423       then
1424          --  Name is a function call with no actuals, in a context that
1425          --  requires deproceduring (including as an actual in an enclosing
1426          --  function or procedure call). There are some pathological cases
1427          --  where the prefix might include functions that return access to
1428          --  subprograms and others that return a regular type. Disambiguation
1429          --  of those has to take place in Resolve.
1430
1431          New_N :=
1432            Make_Function_Call (Loc,
1433            Name => Make_Explicit_Dereference (Loc, P),
1434            Parameter_Associations => New_List);
1435
1436          --  If the prefix is overloaded, remove operations that have formals,
1437          --  we know that this is a parameterless call.
1438
1439          if Is_Overloaded (P) then
1440             Get_First_Interp (P, I, It);
1441             while Present (It.Nam) loop
1442                T := It.Typ;
1443
1444                if No (First_Formal (Base_Type (Designated_Type (T)))) then
1445                   Set_Etype (P, T);
1446                else
1447                   Remove_Interp (I);
1448                end if;
1449
1450                Get_Next_Interp (I, It);
1451             end loop;
1452          end if;
1453
1454          Rewrite (N, New_N);
1455          Analyze (N);
1456
1457       elsif not Is_Function_Type
1458         and then Is_Overloaded (N)
1459       then
1460          --  The prefix may include access to subprograms and other access
1461          --  types. If the context selects the interpretation that is a call,
1462          --  we cannot rewrite the node yet, but we include the result of
1463          --  the call interpretation.
1464
1465          Get_First_Interp (N, I, It);
1466          while Present (It.Nam) loop
1467             if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
1468                and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
1469             then
1470                Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
1471             end if;
1472
1473             Get_Next_Interp (I, It);
1474          end loop;
1475       end if;
1476
1477       --  A value of remote access-to-class-wide must not be dereferenced
1478       --  (RM E.2.2(16)).
1479
1480       Validate_Remote_Access_To_Class_Wide_Type (N);
1481    end Analyze_Explicit_Dereference;
1482
1483    ------------------------
1484    -- Analyze_Expression --
1485    ------------------------
1486
1487    procedure Analyze_Expression (N : Node_Id) is
1488    begin
1489       Analyze (N);
1490       Check_Parameterless_Call (N);
1491    end Analyze_Expression;
1492
1493    ------------------------------------
1494    -- Analyze_Indexed_Component_Form --
1495    ------------------------------------
1496
1497    procedure Analyze_Indexed_Component_Form (N : Node_Id) is
1498       P     : constant Node_Id := Prefix (N);
1499       Exprs : constant List_Id := Expressions (N);
1500       Exp   : Node_Id;
1501       P_T   : Entity_Id;
1502       E     : Node_Id;
1503       U_N   : Entity_Id;
1504
1505       procedure Process_Function_Call;
1506       --  Prefix in indexed component form is an overloadable entity,
1507       --  so the node is a function call. Reformat it as such.
1508
1509       procedure Process_Indexed_Component;
1510       --  Prefix in indexed component form is actually an indexed component.
1511       --  This routine processes it, knowing that the prefix is already
1512       --  resolved.
1513
1514       procedure Process_Indexed_Component_Or_Slice;
1515       --  An indexed component with a single index may designate a slice if
1516       --  the index is a subtype mark. This routine disambiguates these two
1517       --  cases by resolving the prefix to see if it is a subtype mark.
1518
1519       procedure Process_Overloaded_Indexed_Component;
1520       --  If the prefix of an indexed component is overloaded, the proper
1521       --  interpretation is selected by the index types and the context.
1522
1523       ---------------------------
1524       -- Process_Function_Call --
1525       ---------------------------
1526
1527       procedure Process_Function_Call is
1528          Actual : Node_Id;
1529
1530       begin
1531          Change_Node (N, N_Function_Call);
1532          Set_Name (N, P);
1533          Set_Parameter_Associations (N, Exprs);
1534
1535          --  Analyze actuals prior to analyzing the call itself
1536
1537          Actual := First (Parameter_Associations (N));
1538          while Present (Actual) loop
1539             Analyze (Actual);
1540             Check_Parameterless_Call (Actual);
1541
1542             --  Move to next actual. Note that we use Next, not Next_Actual
1543             --  here. The reason for this is a bit subtle. If a function call
1544             --  includes named associations, the parser recognizes the node as
1545             --  a call, and it is analyzed as such. If all associations are
1546             --  positional, the parser builds an indexed_component node, and
1547             --  it is only after analysis of the prefix that the construct
1548             --  is recognized as a call, in which case Process_Function_Call
1549             --  rewrites the node and analyzes the actuals. If the list of
1550             --  actuals is malformed, the parser may leave the node as an
1551             --  indexed component (despite the presence of named associations).
1552             --  The iterator Next_Actual is equivalent to Next if the list is
1553             --  positional, but follows the normalized chain of actuals when
1554             --  named associations are present. In this case normalization has
1555             --  not taken place, and actuals remain unanalyzed, which leads to
1556             --  subsequent crashes or loops if there is an attempt to continue
1557             --  analysis of the program.
1558
1559             Next (Actual);
1560          end loop;
1561
1562          Analyze_Call (N);
1563       end Process_Function_Call;
1564
1565       -------------------------------
1566       -- Process_Indexed_Component --
1567       -------------------------------
1568
1569       procedure Process_Indexed_Component is
1570          Exp        : Node_Id;
1571          Array_Type : Entity_Id;
1572          Index      : Node_Id;
1573          Pent       : Entity_Id := Empty;
1574
1575       begin
1576          Exp := First (Exprs);
1577
1578          if Is_Overloaded (P) then
1579             Process_Overloaded_Indexed_Component;
1580
1581          else
1582             Array_Type := Etype (P);
1583
1584             if Is_Entity_Name (P) then
1585                Pent := Entity (P);
1586             elsif Nkind (P) = N_Selected_Component
1587               and then Is_Entity_Name (Selector_Name (P))
1588             then
1589                Pent := Entity (Selector_Name (P));
1590             end if;
1591
1592             --  Prefix must be appropriate for an array type, taking into
1593             --  account a possible implicit dereference.
1594
1595             if Is_Access_Type (Array_Type) then
1596                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1597                Array_Type := Process_Implicit_Dereference_Prefix (Pent, P);
1598             end if;
1599
1600             if Is_Array_Type (Array_Type) then
1601                null;
1602
1603             elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
1604                Analyze (Exp);
1605                Set_Etype (N, Any_Type);
1606
1607                if not Has_Compatible_Type
1608                  (Exp, Entry_Index_Type (Pent))
1609                then
1610                   Error_Msg_N ("invalid index type in entry name", N);
1611
1612                elsif Present (Next (Exp)) then
1613                   Error_Msg_N ("too many subscripts in entry reference", N);
1614
1615                else
1616                   Set_Etype (N,  Etype (P));
1617                end if;
1618
1619                return;
1620
1621             elsif Is_Record_Type (Array_Type)
1622               and then Remote_AST_I_Dereference (P)
1623             then
1624                return;
1625
1626             elsif Array_Type = Any_Type then
1627                Set_Etype (N, Any_Type);
1628                return;
1629
1630             --  Here we definitely have a bad indexing
1631
1632             else
1633                if Nkind (Parent (N)) = N_Requeue_Statement
1634                  and then Present (Pent) and then Ekind (Pent) = E_Entry
1635                then
1636                   Error_Msg_N
1637                     ("REQUEUE does not permit parameters", First (Exprs));
1638
1639                elsif Is_Entity_Name (P)
1640                  and then Etype (P) = Standard_Void_Type
1641                then
1642                   Error_Msg_NE ("incorrect use of&", P, Entity (P));
1643
1644                else
1645                   Error_Msg_N ("array type required in indexed component", P);
1646                end if;
1647
1648                Set_Etype (N, Any_Type);
1649                return;
1650             end if;
1651
1652             Index := First_Index (Array_Type);
1653             while Present (Index) and then Present (Exp) loop
1654                if not Has_Compatible_Type (Exp, Etype (Index)) then
1655                   Wrong_Type (Exp, Etype (Index));
1656                   Set_Etype (N, Any_Type);
1657                   return;
1658                end if;
1659
1660                Next_Index (Index);
1661                Next (Exp);
1662             end loop;
1663
1664             Set_Etype (N, Component_Type (Array_Type));
1665
1666             if Present (Index) then
1667                Error_Msg_N
1668                  ("too few subscripts in array reference", First (Exprs));
1669
1670             elsif Present (Exp) then
1671                Error_Msg_N ("too many subscripts in array reference", Exp);
1672             end if;
1673          end if;
1674       end Process_Indexed_Component;
1675
1676       ----------------------------------------
1677       -- Process_Indexed_Component_Or_Slice --
1678       ----------------------------------------
1679
1680       procedure Process_Indexed_Component_Or_Slice is
1681       begin
1682          Exp := First (Exprs);
1683          while Present (Exp) loop
1684             Analyze_Expression (Exp);
1685             Next (Exp);
1686          end loop;
1687
1688          Exp := First (Exprs);
1689
1690          --  If one index is present, and it is a subtype name, then the
1691          --  node denotes a slice (note that the case of an explicit range
1692          --  for a slice was already built as an N_Slice node in the first
1693          --  place, so that case is not handled here).
1694
1695          --  We use a replace rather than a rewrite here because this is one
1696          --  of the cases in which the tree built by the parser is plain wrong.
1697
1698          if No (Next (Exp))
1699            and then Is_Entity_Name (Exp)
1700            and then Is_Type (Entity (Exp))
1701          then
1702             Replace (N,
1703                Make_Slice (Sloc (N),
1704                  Prefix => P,
1705                  Discrete_Range => New_Copy (Exp)));
1706             Analyze (N);
1707
1708          --  Otherwise (more than one index present, or single index is not
1709          --  a subtype name), then we have the indexed component case.
1710
1711          else
1712             Process_Indexed_Component;
1713          end if;
1714       end Process_Indexed_Component_Or_Slice;
1715
1716       ------------------------------------------
1717       -- Process_Overloaded_Indexed_Component --
1718       ------------------------------------------
1719
1720       procedure Process_Overloaded_Indexed_Component is
1721          Exp   : Node_Id;
1722          I     : Interp_Index;
1723          It    : Interp;
1724          Typ   : Entity_Id;
1725          Index : Node_Id;
1726          Found : Boolean;
1727
1728       begin
1729          Set_Etype (N, Any_Type);
1730
1731          Get_First_Interp (P, I, It);
1732          while Present (It.Nam) loop
1733             Typ := It.Typ;
1734
1735             if Is_Access_Type (Typ) then
1736                Typ := Designated_Type (Typ);
1737                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1738             end if;
1739
1740             if Is_Array_Type (Typ) then
1741
1742                --  Got a candidate: verify that index types are compatible
1743
1744                Index := First_Index (Typ);
1745                Found := True;
1746                Exp := First (Exprs);
1747                while Present (Index) and then Present (Exp) loop
1748                   if Has_Compatible_Type (Exp, Etype (Index)) then
1749                      null;
1750                   else
1751                      Found := False;
1752                      Remove_Interp (I);
1753                      exit;
1754                   end if;
1755
1756                   Next_Index (Index);
1757                   Next (Exp);
1758                end loop;
1759
1760                if Found and then No (Index) and then No (Exp) then
1761                   Add_One_Interp (N,
1762                      Etype (Component_Type (Typ)),
1763                      Etype (Component_Type (Typ)));
1764                end if;
1765             end if;
1766
1767             Get_Next_Interp (I, It);
1768          end loop;
1769
1770          if Etype (N) = Any_Type then
1771             Error_Msg_N ("no legal interpretation for indexed component", N);
1772             Set_Is_Overloaded (N, False);
1773          end if;
1774
1775          End_Interp_List;
1776       end Process_Overloaded_Indexed_Component;
1777
1778    --  Start of processing for Analyze_Indexed_Component_Form
1779
1780    begin
1781       --  Get name of array, function or type
1782
1783       Analyze (P);
1784
1785       if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then
1786
1787          --  If P is an explicit dereference whose prefix is of a
1788          --  remote access-to-subprogram type, then N has already
1789          --  been rewritten as a subprogram call and analyzed.
1790
1791          return;
1792       end if;
1793
1794       pragma Assert (Nkind (N) = N_Indexed_Component);
1795
1796       P_T := Base_Type (Etype (P));
1797
1798       if Is_Entity_Name (P)
1799         or else Nkind (P) = N_Operator_Symbol
1800       then
1801          U_N := Entity (P);
1802
1803          if Is_Type (U_N) then
1804
1805             --  Reformat node as a type conversion
1806
1807             E := Remove_Head (Exprs);
1808
1809             if Present (First (Exprs)) then
1810                Error_Msg_N
1811                 ("argument of type conversion must be single expression", N);
1812             end if;
1813
1814             Change_Node (N, N_Type_Conversion);
1815             Set_Subtype_Mark (N, P);
1816             Set_Etype (N, U_N);
1817             Set_Expression (N, E);
1818
1819             --  After changing the node, call for the specific Analysis
1820             --  routine directly, to avoid a double call to the expander.
1821
1822             Analyze_Type_Conversion (N);
1823             return;
1824          end if;
1825
1826          if Is_Overloadable (U_N) then
1827             Process_Function_Call;
1828
1829          elsif Ekind (Etype (P)) = E_Subprogram_Type
1830            or else (Is_Access_Type (Etype (P))
1831                       and then
1832                     Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
1833          then
1834             --  Call to access_to-subprogram with possible implicit dereference
1835
1836             Process_Function_Call;
1837
1838          elsif Is_Generic_Subprogram (U_N) then
1839
1840             --  A common beginner's (or C++ templates fan) error
1841
1842             Error_Msg_N ("generic subprogram cannot be called", N);
1843             Set_Etype (N, Any_Type);
1844             return;
1845
1846          else
1847             Process_Indexed_Component_Or_Slice;
1848          end if;
1849
1850       --  If not an entity name, prefix is an expression that may denote
1851       --  an array or an access-to-subprogram.
1852
1853       else
1854          if Ekind (P_T) = E_Subprogram_Type
1855            or else (Is_Access_Type (P_T)
1856                      and then
1857                     Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
1858          then
1859             Process_Function_Call;
1860
1861          elsif Nkind (P) = N_Selected_Component
1862            and then Is_Overloadable (Entity (Selector_Name (P)))
1863          then
1864             Process_Function_Call;
1865
1866          else
1867             --  Indexed component, slice, or a call to a member of a family
1868             --  entry, which will be converted to an entry call later.
1869
1870             Process_Indexed_Component_Or_Slice;
1871          end if;
1872       end if;
1873    end Analyze_Indexed_Component_Form;
1874
1875    ------------------------
1876    -- Analyze_Logical_Op --
1877    ------------------------
1878
1879    procedure Analyze_Logical_Op (N : Node_Id) is
1880       L     : constant Node_Id := Left_Opnd (N);
1881       R     : constant Node_Id := Right_Opnd (N);
1882       Op_Id : Entity_Id := Entity (N);
1883
1884    begin
1885       Set_Etype (N, Any_Type);
1886       Candidate_Type := Empty;
1887
1888       Analyze_Expression (L);
1889       Analyze_Expression (R);
1890
1891       if Present (Op_Id) then
1892
1893          if Ekind (Op_Id) = E_Operator then
1894             Find_Boolean_Types (L, R, Op_Id, N);
1895          else
1896             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1897          end if;
1898
1899       else
1900          Op_Id := Get_Name_Entity_Id (Chars (N));
1901          while Present (Op_Id) loop
1902             if Ekind (Op_Id) = E_Operator then
1903                Find_Boolean_Types (L, R, Op_Id, N);
1904             else
1905                Analyze_User_Defined_Binary_Op (N, Op_Id);
1906             end if;
1907
1908             Op_Id := Homonym (Op_Id);
1909          end loop;
1910       end if;
1911
1912       Operator_Check (N);
1913    end Analyze_Logical_Op;
1914
1915    ---------------------------
1916    -- Analyze_Membership_Op --
1917    ---------------------------
1918
1919    procedure Analyze_Membership_Op (N : Node_Id) is
1920       L     : constant Node_Id := Left_Opnd (N);
1921       R     : constant Node_Id := Right_Opnd (N);
1922
1923       Index : Interp_Index;
1924       It    : Interp;
1925       Found : Boolean := False;
1926       I_F   : Interp_Index;
1927       T_F   : Entity_Id;
1928
1929       procedure Try_One_Interp (T1 : Entity_Id);
1930       --  Routine to try one proposed interpretation. Note that the context
1931       --  of the operation plays no role in resolving the arguments, so that
1932       --  if there is more than one interpretation of the operands that is
1933       --  compatible with a membership test, the operation is ambiguous.
1934
1935       --------------------
1936       -- Try_One_Interp --
1937       --------------------
1938
1939       procedure Try_One_Interp (T1 : Entity_Id) is
1940       begin
1941          if Has_Compatible_Type (R, T1) then
1942             if Found
1943               and then Base_Type (T1) /= Base_Type (T_F)
1944             then
1945                It := Disambiguate (L, I_F, Index, Any_Type);
1946
1947                if It = No_Interp then
1948                   Ambiguous_Operands (N);
1949                   Set_Etype (L, Any_Type);
1950                   return;
1951
1952                else
1953                   T_F := It.Typ;
1954                end if;
1955
1956             else
1957                Found := True;
1958                T_F   := T1;
1959                I_F   := Index;
1960             end if;
1961
1962             Set_Etype (L, T_F);
1963          end if;
1964
1965       end Try_One_Interp;
1966
1967    --  Start of processing for Analyze_Membership_Op
1968
1969    begin
1970       Analyze_Expression (L);
1971
1972       if Nkind (R) = N_Range
1973         or else (Nkind (R) = N_Attribute_Reference
1974                   and then Attribute_Name (R) = Name_Range)
1975       then
1976          Analyze (R);
1977
1978          if not Is_Overloaded (L) then
1979             Try_One_Interp (Etype (L));
1980
1981          else
1982             Get_First_Interp (L, Index, It);
1983             while Present (It.Typ) loop
1984                Try_One_Interp (It.Typ);
1985                Get_Next_Interp (Index, It);
1986             end loop;
1987          end if;
1988
1989       --  If not a range, it can only be a subtype mark, or else there
1990       --  is a more basic error, to be diagnosed in Find_Type.
1991
1992       else
1993          Find_Type (R);
1994
1995          if Is_Entity_Name (R) then
1996             Check_Fully_Declared (Entity (R), R);
1997          end if;
1998       end if;
1999
2000       --  Compatibility between expression and subtype mark or range is
2001       --  checked during resolution. The result of the operation is Boolean
2002       --  in any case.
2003
2004       Set_Etype (N, Standard_Boolean);
2005
2006       if Comes_From_Source (N)
2007         and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
2008       then
2009          Error_Msg_N ("membership test not applicable to cpp-class types", N);
2010       end if;
2011    end Analyze_Membership_Op;
2012
2013    ----------------------
2014    -- Analyze_Negation --
2015    ----------------------
2016
2017    procedure Analyze_Negation (N : Node_Id) is
2018       R     : constant Node_Id := Right_Opnd (N);
2019       Op_Id : Entity_Id := Entity (N);
2020
2021    begin
2022       Set_Etype (N, Any_Type);
2023       Candidate_Type := Empty;
2024
2025       Analyze_Expression (R);
2026
2027       if Present (Op_Id) then
2028          if Ekind (Op_Id) = E_Operator then
2029             Find_Negation_Types (R, Op_Id, N);
2030          else
2031             Add_One_Interp (N, Op_Id, Etype (Op_Id));
2032          end if;
2033
2034       else
2035          Op_Id := Get_Name_Entity_Id (Chars (N));
2036          while Present (Op_Id) loop
2037             if Ekind (Op_Id) = E_Operator then
2038                Find_Negation_Types (R, Op_Id, N);
2039             else
2040                Analyze_User_Defined_Unary_Op (N, Op_Id);
2041             end if;
2042
2043             Op_Id := Homonym (Op_Id);
2044          end loop;
2045       end if;
2046
2047       Operator_Check (N);
2048    end Analyze_Negation;
2049
2050    ------------------
2051    -- Analyze_Null --
2052    ------------------
2053
2054    procedure Analyze_Null (N : Node_Id) is
2055    begin
2056       Set_Etype (N, Any_Access);
2057    end Analyze_Null;
2058
2059    ----------------------
2060    -- Analyze_One_Call --
2061    ----------------------
2062
2063    procedure Analyze_One_Call
2064       (N          : Node_Id;
2065        Nam        : Entity_Id;
2066        Report     : Boolean;
2067        Success    : out Boolean;
2068        Skip_First : Boolean := False)
2069    is
2070       Actuals : constant List_Id   := Parameter_Associations (N);
2071       Prev_T  : constant Entity_Id := Etype (N);
2072
2073       Must_Skip  : constant Boolean := Skip_First
2074                      or else Nkind (Original_Node (N)) = N_Selected_Component
2075                      or else
2076                        (Nkind (Original_Node (N)) = N_Indexed_Component
2077                           and then Nkind (Prefix (Original_Node (N)))
2078                             = N_Selected_Component);
2079       --  The first formal must be omitted from the match when trying to find
2080       --  a primitive operation that is a possible interpretation, and also
2081       --  after the call has been rewritten, because the corresponding actual
2082       --  is already known to be compatible, and because this may be an
2083       --  indexing of a call with default parameters.
2084
2085       Formal     : Entity_Id;
2086       Actual     : Node_Id;
2087       Is_Indexed : Boolean := False;
2088       Subp_Type  : constant Entity_Id := Etype (Nam);
2089       Norm_OK    : Boolean;
2090
2091       function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
2092       --  There may be a user-defined operator that hides the current
2093       --  interpretation. We must check for this independently of the
2094       --  analysis of the call with the user-defined operation, because
2095       --  the parameter names may be wrong and yet the hiding takes place.
2096       --  This fixes a problem with ACATS test B34014O.
2097       --
2098       --  When the type Address is a visible integer type, and the DEC
2099       --  system extension is visible, the predefined operator may be
2100       --  hidden as well, by one of the address operations in auxdec.
2101       --  Finally, The abstract operations on address do not hide the
2102       --  predefined operator (this is the purpose of making them abstract).
2103
2104       procedure Indicate_Name_And_Type;
2105       --  If candidate interpretation matches, indicate name and type of
2106       --  result on call node.
2107
2108       ----------------------------
2109       -- Indicate_Name_And_Type --
2110       ----------------------------
2111
2112       procedure Indicate_Name_And_Type is
2113       begin
2114          Add_One_Interp (N, Nam, Etype (Nam));
2115          Success := True;
2116
2117          --  If the prefix of the call is a name, indicate the entity
2118          --  being called. If it is not a name,  it is an expression that
2119          --  denotes an access to subprogram or else an entry or family. In
2120          --  the latter case, the name is a selected component, and the entity
2121          --  being called is noted on the selector.
2122
2123          if not Is_Type (Nam) then
2124             if Is_Entity_Name (Name (N))
2125               or else Nkind (Name (N)) = N_Operator_Symbol
2126             then
2127                Set_Entity (Name (N), Nam);
2128
2129             elsif Nkind (Name (N)) = N_Selected_Component then
2130                Set_Entity (Selector_Name (Name (N)),  Nam);
2131             end if;
2132          end if;
2133
2134          if Debug_Flag_E and not Report then
2135             Write_Str (" Overloaded call ");
2136             Write_Int (Int (N));
2137             Write_Str (" compatible with ");
2138             Write_Int (Int (Nam));
2139             Write_Eol;
2140          end if;
2141       end Indicate_Name_And_Type;
2142
2143       ------------------------
2144       -- Operator_Hidden_By --
2145       ------------------------
2146
2147       function Operator_Hidden_By (Fun : Entity_Id) return Boolean is
2148          Act1  : constant Node_Id   := First_Actual (N);
2149          Act2  : constant Node_Id   := Next_Actual (Act1);
2150          Form1 : constant Entity_Id := First_Formal (Fun);
2151          Form2 : constant Entity_Id := Next_Formal (Form1);
2152
2153       begin
2154          if Ekind (Fun) /= E_Function
2155            or else Is_Abstract_Subprogram (Fun)
2156          then
2157             return False;
2158
2159          elsif not Has_Compatible_Type (Act1, Etype (Form1)) then
2160             return False;
2161
2162          elsif Present (Form2) then
2163             if
2164               No (Act2) or else not Has_Compatible_Type (Act2, Etype (Form2))
2165             then
2166                return False;
2167             end if;
2168
2169          elsif Present (Act2) then
2170             return False;
2171          end if;
2172
2173          --  Now we know that the arity of the operator matches the function,
2174          --  and the function call is a valid interpretation. The function
2175          --  hides the operator if it has the right signature, or if one of
2176          --  its operands is a non-abstract operation on Address when this is
2177          --  a visible integer type.
2178
2179          return Hides_Op (Fun, Nam)
2180            or else Is_Descendent_Of_Address (Etype (Form1))
2181            or else
2182              (Present (Form2)
2183                and then Is_Descendent_Of_Address (Etype (Form2)));
2184       end Operator_Hidden_By;
2185
2186    --  Start of processing for Analyze_One_Call
2187
2188    begin
2189       Success := False;
2190
2191       --  If the subprogram has no formals or if all the formals have defaults,
2192       --  and the return type is an array type, the node may denote an indexing
2193       --  of the result of a parameterless call. In Ada 2005, the subprogram
2194       --  may have one non-defaulted formal, and the call may have been written
2195       --  in prefix notation, so that the rebuilt parameter list has more than
2196       --  one actual.
2197
2198       if Present (Actuals)
2199         and then
2200           (Needs_No_Actuals (Nam)
2201             or else
2202               (Needs_One_Actual (Nam)
2203                  and then Present (Next_Actual (First (Actuals)))))
2204       then
2205          if Is_Array_Type (Subp_Type) then
2206             Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip);
2207
2208          elsif Is_Access_Type (Subp_Type)
2209            and then Is_Array_Type (Designated_Type (Subp_Type))
2210          then
2211             Is_Indexed :=
2212               Try_Indexed_Call
2213                 (N, Nam, Designated_Type (Subp_Type), Must_Skip);
2214
2215          --  The prefix can also be a parameterless function that returns an
2216          --  access to subprogram. in which case this is an indirect call.
2217
2218          elsif Is_Access_Type (Subp_Type)
2219            and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
2220          then
2221             Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
2222          end if;
2223
2224       end if;
2225
2226       Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
2227
2228       if not Norm_OK then
2229
2230          --  Mismatch in number or names of parameters
2231
2232          if Debug_Flag_E then
2233             Write_Str (" normalization fails in call ");
2234             Write_Int (Int (N));
2235             Write_Str (" with subprogram ");
2236             Write_Int (Int (Nam));
2237             Write_Eol;
2238          end if;
2239
2240       --  If the context expects a function call, discard any interpretation
2241       --  that is a procedure. If the node is not overloaded, leave as is for
2242       --  better error reporting when type mismatch is found.
2243
2244       elsif Nkind (N) = N_Function_Call
2245         and then Is_Overloaded (Name (N))
2246         and then Ekind (Nam) = E_Procedure
2247       then
2248          return;
2249
2250       --  Ditto for function calls in a procedure context
2251
2252       elsif Nkind (N) = N_Procedure_Call_Statement
2253          and then Is_Overloaded (Name (N))
2254          and then Etype (Nam) /= Standard_Void_Type
2255       then
2256          return;
2257
2258       elsif No (Actuals) then
2259
2260          --  If Normalize succeeds, then there are default parameters for
2261          --  all formals.
2262
2263          Indicate_Name_And_Type;
2264
2265       elsif Ekind (Nam) = E_Operator then
2266          if Nkind (N) = N_Procedure_Call_Statement then
2267             return;
2268          end if;
2269
2270          --  This can occur when the prefix of the call is an operator
2271          --  name or an expanded name whose selector is an operator name.
2272
2273          Analyze_Operator_Call (N, Nam);
2274
2275          if Etype (N) /= Prev_T then
2276
2277             --  Check that operator is not hidden by a function interpretation
2278
2279             if Is_Overloaded (Name (N)) then
2280                declare
2281                   I  : Interp_Index;
2282                   It : Interp;
2283
2284                begin
2285                   Get_First_Interp (Name (N), I, It);
2286                   while Present (It.Nam) loop
2287                      if Operator_Hidden_By (It.Nam) then
2288                         Set_Etype (N, Prev_T);
2289                         return;
2290                      end if;
2291
2292                      Get_Next_Interp (I, It);
2293                   end loop;
2294                end;
2295             end if;
2296
2297             --  If operator matches formals, record its name on the call.
2298             --  If the operator is overloaded, Resolve will select the
2299             --  correct one from the list of interpretations. The call
2300             --  node itself carries the first candidate.
2301
2302             Set_Entity (Name (N), Nam);
2303             Success := True;
2304
2305          elsif Report and then Etype (N) = Any_Type then
2306             Error_Msg_N ("incompatible arguments for operator", N);
2307          end if;
2308
2309       else
2310          --  Normalize_Actuals has chained the named associations in the
2311          --  correct order of the formals.
2312
2313          Actual := First_Actual (N);
2314          Formal := First_Formal (Nam);
2315
2316          --  If we are analyzing a call rewritten from object notation,
2317          --  skip first actual, which may be rewritten later as an
2318          --  explicit dereference.
2319
2320          if Must_Skip then
2321             Next_Actual (Actual);
2322             Next_Formal (Formal);
2323          end if;
2324
2325          while Present (Actual) and then Present (Formal) loop
2326             if Nkind (Parent (Actual)) /= N_Parameter_Association
2327               or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
2328             then
2329                --  The actual can be compatible with the formal, but we must
2330                --  also check that the context is not an address type that is
2331                --  visibly an integer type, as is the case in VMS_64. In this
2332                --  case the use of literals is illegal, except in the body of
2333                --  descendents of system, where arithmetic operations on
2334                --  address are of course used.
2335
2336                if Has_Compatible_Type (Actual, Etype (Formal))
2337                  and then
2338                   (Etype (Actual) /= Universal_Integer
2339                     or else not Is_Descendent_Of_Address (Etype (Formal))
2340                     or else
2341                       Is_Predefined_File_Name
2342                         (Unit_File_Name (Get_Source_Unit (N))))
2343                then
2344                   Next_Actual (Actual);
2345                   Next_Formal (Formal);
2346
2347                else
2348                   if Debug_Flag_E then
2349                      Write_Str (" type checking fails in call ");
2350                      Write_Int (Int (N));
2351                      Write_Str (" with formal ");
2352                      Write_Int (Int (Formal));
2353                      Write_Str (" in subprogram ");
2354                      Write_Int (Int (Nam));
2355                      Write_Eol;
2356                   end if;
2357
2358                   if Report and not Is_Indexed then
2359
2360                      --  Ada 2005 (AI-251): Complete the error notification
2361                      --  to help new Ada 2005 users
2362
2363                      if Is_Class_Wide_Type (Etype (Formal))
2364                        and then Is_Interface (Etype (Etype (Formal)))
2365                        and then not Interface_Present_In_Ancestor
2366                                       (Typ   => Etype (Actual),
2367                                        Iface => Etype (Etype (Formal)))
2368                      then
2369                         Error_Msg_NE
2370                           ("(Ada 2005) does not implement interface }",
2371                            Actual, Etype (Etype (Formal)));
2372                      end if;
2373
2374                      Wrong_Type (Actual, Etype (Formal));
2375
2376                      if Nkind (Actual) = N_Op_Eq
2377                        and then Nkind (Left_Opnd (Actual)) = N_Identifier
2378                      then
2379                         Formal := First_Formal (Nam);
2380                         while Present (Formal) loop
2381                            if Chars (Left_Opnd (Actual)) = Chars (Formal) then
2382                               Error_Msg_N
2383                                 ("possible misspelling of `='>`!", Actual);
2384                               exit;
2385                            end if;
2386
2387                            Next_Formal (Formal);
2388                         end loop;
2389                      end if;
2390
2391                      if All_Errors_Mode then
2392                         Error_Msg_Sloc := Sloc (Nam);
2393
2394                         if Is_Overloadable (Nam)
2395                           and then Present (Alias (Nam))
2396                           and then not Comes_From_Source (Nam)
2397                         then
2398                            Error_Msg_NE
2399                              ("\\  =='> in call to inherited operation & #!",
2400                               Actual, Nam);
2401
2402                         elsif Ekind (Nam) = E_Subprogram_Type then
2403                            declare
2404                               Access_To_Subprogram_Typ :
2405                                 constant Entity_Id :=
2406                                   Defining_Identifier
2407                                     (Associated_Node_For_Itype (Nam));
2408                            begin
2409                               Error_Msg_NE (
2410                                 "\\  =='> in call to dereference of &#!",
2411                                 Actual, Access_To_Subprogram_Typ);
2412                            end;
2413
2414                         else
2415                            Error_Msg_NE
2416                              ("\\  =='> in call to &#!", Actual, Nam);
2417
2418                         end if;
2419                      end if;
2420                   end if;
2421
2422                   return;
2423                end if;
2424
2425             else
2426                --  Normalize_Actuals has verified that a default value exists
2427                --  for this formal. Current actual names a subsequent formal.
2428
2429                Next_Formal (Formal);
2430             end if;
2431          end loop;
2432
2433          --  On exit, all actuals match
2434
2435          Indicate_Name_And_Type;
2436       end if;
2437    end Analyze_One_Call;
2438
2439    ---------------------------
2440    -- Analyze_Operator_Call --
2441    ---------------------------
2442
2443    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
2444       Op_Name : constant Name_Id := Chars (Op_Id);
2445       Act1    : constant Node_Id := First_Actual (N);
2446       Act2    : constant Node_Id := Next_Actual (Act1);
2447
2448    begin
2449       --  Binary operator case
2450
2451       if Present (Act2) then
2452
2453          --  If more than two operands, then not binary operator after all
2454
2455          if Present (Next_Actual (Act2)) then
2456             return;
2457
2458          elsif     Op_Name = Name_Op_Add
2459            or else Op_Name = Name_Op_Subtract
2460            or else Op_Name = Name_Op_Multiply
2461            or else Op_Name = Name_Op_Divide
2462            or else Op_Name = Name_Op_Mod
2463            or else Op_Name = Name_Op_Rem
2464            or else Op_Name = Name_Op_Expon
2465          then
2466             Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
2467
2468          elsif     Op_Name =  Name_Op_And
2469            or else Op_Name = Name_Op_Or
2470            or else Op_Name = Name_Op_Xor
2471          then
2472             Find_Boolean_Types (Act1, Act2, Op_Id, N);
2473
2474          elsif     Op_Name = Name_Op_Lt
2475            or else Op_Name = Name_Op_Le
2476            or else Op_Name = Name_Op_Gt
2477            or else Op_Name = Name_Op_Ge
2478          then
2479             Find_Comparison_Types (Act1, Act2, Op_Id,  N);
2480
2481          elsif     Op_Name = Name_Op_Eq
2482            or else Op_Name = Name_Op_Ne
2483          then
2484             Find_Equality_Types (Act1, Act2, Op_Id,  N);
2485
2486          elsif     Op_Name = Name_Op_Concat then
2487             Find_Concatenation_Types (Act1, Act2, Op_Id, N);
2488
2489          --  Is this else null correct, or should it be an abort???
2490
2491          else
2492             null;
2493          end if;
2494
2495       --  Unary operator case
2496
2497       else
2498          if Op_Name = Name_Op_Subtract or else
2499             Op_Name = Name_Op_Add      or else
2500             Op_Name = Name_Op_Abs
2501          then
2502             Find_Unary_Types (Act1, Op_Id, N);
2503
2504          elsif
2505             Op_Name = Name_Op_Not
2506          then
2507             Find_Negation_Types (Act1, Op_Id, N);
2508
2509          --  Is this else null correct, or should it be an abort???
2510
2511          else
2512             null;
2513          end if;
2514       end if;
2515    end Analyze_Operator_Call;
2516
2517    -------------------------------------------
2518    -- Analyze_Overloaded_Selected_Component --
2519    -------------------------------------------
2520
2521    procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
2522       Nam   : constant Node_Id := Prefix (N);
2523       Sel   : constant Node_Id := Selector_Name (N);
2524       Comp  : Entity_Id;
2525       I     : Interp_Index;
2526       It    : Interp;
2527       T     : Entity_Id;
2528
2529    begin
2530       Set_Etype (Sel, Any_Type);
2531
2532       Get_First_Interp (Nam, I, It);
2533       while Present (It.Typ) loop
2534          if Is_Access_Type (It.Typ) then
2535             T := Designated_Type (It.Typ);
2536             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2537          else
2538             T := It.Typ;
2539          end if;
2540
2541          if Is_Record_Type (T) then
2542
2543             --  If the prefix is a class-wide type, the visible components are
2544             --  those of the base type.
2545
2546             if Is_Class_Wide_Type (T) then
2547                T := Etype (T);
2548             end if;
2549
2550             Comp := First_Entity (T);
2551             while Present (Comp) loop
2552                if Chars (Comp) = Chars (Sel)
2553                  and then Is_Visible_Component (Comp)
2554                then
2555                   Set_Entity (Sel, Comp);
2556                   Set_Etype (Sel, Etype (Comp));
2557                   Add_One_Interp (N, Etype (Comp), Etype (Comp));
2558
2559                   --  This also specifies a candidate to resolve the name.
2560                   --  Further overloading will be resolved from context.
2561
2562                   Set_Etype (Nam, It.Typ);
2563                end if;
2564
2565                Next_Entity (Comp);
2566             end loop;
2567
2568          elsif Is_Concurrent_Type (T) then
2569             Comp := First_Entity (T);
2570             while Present (Comp)
2571               and then Comp /= First_Private_Entity (T)
2572             loop
2573                if Chars (Comp) = Chars (Sel) then
2574                   if Is_Overloadable (Comp) then
2575                      Add_One_Interp (Sel, Comp, Etype (Comp));
2576                   else
2577                      Set_Entity_With_Style_Check (Sel, Comp);
2578                      Generate_Reference (Comp, Sel);
2579                   end if;
2580
2581                   Set_Etype (Sel, Etype (Comp));
2582                   Set_Etype (N,   Etype (Comp));
2583                   Set_Etype (Nam, It.Typ);
2584
2585                   --  For access type case, introduce explicit deference for
2586                   --  more uniform treatment of entry calls. Do this only
2587                   --  once if several interpretations yield an access type.
2588
2589                   if Is_Access_Type (Etype (Nam))
2590                     and then Nkind (Nam) /= N_Explicit_Dereference
2591                   then
2592                      Insert_Explicit_Dereference (Nam);
2593                      Error_Msg_NW
2594                        (Warn_On_Dereference, "?implicit dereference", N);
2595                   end if;
2596                end if;
2597
2598                Next_Entity (Comp);
2599             end loop;
2600
2601             Set_Is_Overloaded (N, Is_Overloaded (Sel));
2602          end if;
2603
2604          Get_Next_Interp (I, It);
2605       end loop;
2606
2607       if Etype (N) = Any_Type
2608         and then not Try_Object_Operation (N)
2609       then
2610          Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
2611          Set_Entity (Sel, Any_Id);
2612          Set_Etype  (Sel, Any_Type);
2613       end if;
2614    end Analyze_Overloaded_Selected_Component;
2615
2616    ----------------------------------
2617    -- Analyze_Qualified_Expression --
2618    ----------------------------------
2619
2620    procedure Analyze_Qualified_Expression (N : Node_Id) is
2621       Mark : constant Entity_Id := Subtype_Mark (N);
2622       Expr : constant Node_Id   := Expression (N);
2623       I    : Interp_Index;
2624       It   : Interp;
2625       T    : Entity_Id;
2626
2627    begin
2628       Analyze_Expression (Expr);
2629
2630       Set_Etype (N, Any_Type);
2631       Find_Type (Mark);
2632       T := Entity (Mark);
2633       Set_Etype (N, T);
2634
2635       if T = Any_Type then
2636          return;
2637       end if;
2638
2639       Check_Fully_Declared (T, N);
2640
2641       --  If expected type is class-wide, check for exact match before
2642       --  expansion, because if the expression is a dispatching call it
2643       --  may be rewritten as explicit dereference with class-wide result.
2644       --  If expression is overloaded, retain only interpretations that
2645       --  will yield exact matches.
2646
2647       if Is_Class_Wide_Type (T) then
2648          if not Is_Overloaded (Expr) then
2649             if  Base_Type (Etype (Expr)) /= Base_Type (T) then
2650                if Nkind (Expr) = N_Aggregate then
2651                   Error_Msg_N ("type of aggregate cannot be class-wide", Expr);
2652                else
2653                   Wrong_Type (Expr, T);
2654                end if;
2655             end if;
2656
2657          else
2658             Get_First_Interp (Expr, I, It);
2659
2660             while Present (It.Nam) loop
2661                if Base_Type (It.Typ) /= Base_Type (T) then
2662                   Remove_Interp (I);
2663                end if;
2664
2665                Get_Next_Interp (I, It);
2666             end loop;
2667          end if;
2668       end if;
2669
2670       Set_Etype  (N, T);
2671    end Analyze_Qualified_Expression;
2672
2673    -------------------
2674    -- Analyze_Range --
2675    -------------------
2676
2677    procedure Analyze_Range (N : Node_Id) is
2678       L        : constant Node_Id := Low_Bound (N);
2679       H        : constant Node_Id := High_Bound (N);
2680       I1, I2   : Interp_Index;
2681       It1, It2 : Interp;
2682
2683       procedure Check_Common_Type (T1, T2 : Entity_Id);
2684       --  Verify the compatibility of two types,  and choose the
2685       --  non universal one if the other is universal.
2686
2687       procedure Check_High_Bound (T : Entity_Id);
2688       --  Test one interpretation of the low bound against all those
2689       --  of the high bound.
2690
2691       procedure Check_Universal_Expression (N : Node_Id);
2692       --  In Ada83, reject bounds of a universal range that are not
2693       --  literals or entity names.
2694
2695       -----------------------
2696       -- Check_Common_Type --
2697       -----------------------
2698
2699       procedure Check_Common_Type (T1, T2 : Entity_Id) is
2700       begin
2701          if Covers (T1 => T1, T2 => T2)
2702               or else
2703             Covers (T1 => T2, T2 => T1)
2704          then
2705             if T1 = Universal_Integer
2706               or else T1 = Universal_Real
2707               or else T1 = Any_Character
2708             then
2709                Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
2710
2711             elsif T1 = T2 then
2712                Add_One_Interp (N, T1, T1);
2713
2714             else
2715                Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
2716             end if;
2717          end if;
2718       end Check_Common_Type;
2719
2720       ----------------------
2721       -- Check_High_Bound --
2722       ----------------------
2723
2724       procedure Check_High_Bound (T : Entity_Id) is
2725       begin
2726          if not Is_Overloaded (H) then
2727             Check_Common_Type (T, Etype (H));
2728          else
2729             Get_First_Interp (H, I2, It2);
2730             while Present (It2.Typ) loop
2731                Check_Common_Type (T, It2.Typ);
2732                Get_Next_Interp (I2, It2);
2733             end loop;
2734          end if;
2735       end Check_High_Bound;
2736
2737       -----------------------------
2738       -- Is_Universal_Expression --
2739       -----------------------------
2740
2741       procedure Check_Universal_Expression (N : Node_Id) is
2742       begin
2743          if Etype (N) = Universal_Integer
2744            and then Nkind (N) /= N_Integer_Literal
2745            and then not Is_Entity_Name (N)
2746            and then Nkind (N) /= N_Attribute_Reference
2747          then
2748             Error_Msg_N ("illegal bound in discrete range", N);
2749          end if;
2750       end Check_Universal_Expression;
2751
2752    --  Start of processing for Analyze_Range
2753
2754    begin
2755       Set_Etype (N, Any_Type);
2756       Analyze_Expression (L);
2757       Analyze_Expression (H);
2758
2759       if Etype (L) = Any_Type or else Etype (H) = Any_Type then
2760          return;
2761
2762       else
2763          if not Is_Overloaded (L) then
2764             Check_High_Bound (Etype (L));
2765          else
2766             Get_First_Interp (L, I1, It1);
2767             while Present (It1.Typ) loop
2768                Check_High_Bound (It1.Typ);
2769                Get_Next_Interp (I1, It1);
2770             end loop;
2771          end if;
2772
2773          --  If result is Any_Type, then we did not find a compatible pair
2774
2775          if Etype (N) = Any_Type then
2776             Error_Msg_N ("incompatible types in range ", N);
2777          end if;
2778       end if;
2779
2780       if Ada_Version = Ada_83
2781         and then
2782           (Nkind (Parent (N)) = N_Loop_Parameter_Specification
2783              or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
2784       then
2785          Check_Universal_Expression (L);
2786          Check_Universal_Expression (H);
2787       end if;
2788    end Analyze_Range;
2789
2790    -----------------------
2791    -- Analyze_Reference --
2792    -----------------------
2793
2794    procedure Analyze_Reference (N : Node_Id) is
2795       P        : constant Node_Id := Prefix (N);
2796       E        : Entity_Id;
2797       T        : Entity_Id;
2798       Acc_Type : Entity_Id;
2799
2800    begin
2801       Analyze (P);
2802
2803       --  An interesting error check, if we take the 'Reference of an object
2804       --  for which a pragma Atomic or Volatile has been given, and the type
2805       --  of the object is not Atomic or Volatile, then we are in trouble. The
2806       --  problem is that no trace of the atomic/volatile status will remain
2807       --  for the backend to respect when it deals with the resulting pointer,
2808       --  since the pointer type will not be marked atomic (it is a pointer to
2809       --  the base type of the object).
2810
2811       --  It is not clear if that can ever occur, but in case it does, we will
2812       --  generate an error message. Not clear if this message can ever be
2813       --  generated, and pretty clear that it represents a bug if it is, still
2814       --  seems worth checking!
2815
2816       T := Etype (P);
2817
2818       if Is_Entity_Name (P)
2819         and then Is_Object_Reference (P)
2820       then
2821          E := Entity (P);
2822          T := Etype (P);
2823
2824          if (Has_Atomic_Components   (E)
2825                and then not Has_Atomic_Components   (T))
2826            or else
2827             (Has_Volatile_Components (E)
2828                and then not Has_Volatile_Components (T))
2829            or else (Is_Atomic   (E) and then not Is_Atomic   (T))
2830            or else (Is_Volatile (E) and then not Is_Volatile (T))
2831          then
2832             Error_Msg_N ("cannot take reference to Atomic/Volatile object", N);
2833          end if;
2834       end if;
2835
2836       --  Carry on with normal processing
2837
2838       Acc_Type := Create_Itype (E_Allocator_Type, N);
2839       Set_Etype (Acc_Type,  Acc_Type);
2840       Set_Directly_Designated_Type (Acc_Type, Etype (P));
2841       Set_Etype (N, Acc_Type);
2842    end Analyze_Reference;
2843
2844    --------------------------------
2845    -- Analyze_Selected_Component --
2846    --------------------------------
2847
2848    --  Prefix is a record type or a task or protected type. In the
2849    --  later case, the selector must denote a visible entry.
2850
2851    procedure Analyze_Selected_Component (N : Node_Id) is
2852       Name          : constant Node_Id := Prefix (N);
2853       Sel           : constant Node_Id := Selector_Name (N);
2854       Act_Decl      : Node_Id;
2855       Comp          : Entity_Id;
2856       Has_Candidate : Boolean := False;
2857       In_Scope      : Boolean;
2858       Parent_N      : Node_Id;
2859       Pent          : Entity_Id := Empty;
2860       Prefix_Type   : Entity_Id;
2861
2862       Type_To_Use : Entity_Id;
2863       --  In most cases this is the Prefix_Type, but if the Prefix_Type is
2864       --  a class-wide type, we use its root type, whose components are
2865       --  present in the class-wide type.
2866
2867       function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
2868       --  It is known that the parent of N denotes a subprogram call. Comp
2869       --  is an overloadable component of the concurrent type of the prefix.
2870       --  Determine whether all formals of the parent of N and Comp are mode
2871       --  conformant. If the parent node is not analyzed yet it may be an
2872       --  indexed component rather than a function call.
2873
2874       ------------------------------
2875       -- Has_Mode_Conformant_Spec --
2876       ------------------------------
2877
2878       function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean is
2879          Comp_Param : Entity_Id;
2880          Param      : Node_Id;
2881          Param_Typ  : Entity_Id;
2882
2883       begin
2884          Comp_Param := First_Formal (Comp);
2885
2886          if Nkind (Parent (N)) = N_Indexed_Component then
2887             Param := First (Expressions (Parent (N)));
2888          else
2889             Param := First (Parameter_Associations (Parent (N)));
2890          end if;
2891
2892          while Present (Comp_Param)
2893            and then Present (Param)
2894          loop
2895             Param_Typ := Find_Parameter_Type (Param);
2896
2897             if Present (Param_Typ)
2898               and then
2899                 not Conforming_Types
2900                      (Etype (Comp_Param), Param_Typ, Mode_Conformant)
2901             then
2902                return False;
2903             end if;
2904
2905             Next_Formal (Comp_Param);
2906             Next (Param);
2907          end loop;
2908
2909          --  One of the specs has additional formals
2910
2911          if Present (Comp_Param) or else Present (Param) then
2912             return False;
2913          end if;
2914
2915          return True;
2916       end Has_Mode_Conformant_Spec;
2917
2918    --  Start of processing for Analyze_Selected_Component
2919
2920    begin
2921       Set_Etype (N, Any_Type);
2922
2923       if Is_Overloaded (Name) then
2924          Analyze_Overloaded_Selected_Component (N);
2925          return;
2926
2927       elsif Etype (Name) = Any_Type then
2928          Set_Entity (Sel, Any_Id);
2929          Set_Etype (Sel, Any_Type);
2930          return;
2931
2932       else
2933          Prefix_Type := Etype (Name);
2934       end if;
2935
2936       if Is_Access_Type (Prefix_Type) then
2937
2938          --  A RACW object can never be used as prefix of a selected
2939          --  component since that means it is dereferenced without
2940          --  being a controlling operand of a dispatching operation
2941          --  (RM E.2.2(16/1)). Before reporting an error, we must check
2942          --  whether this is actually a dispatching call in prefix form.
2943
2944          if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
2945            and then Comes_From_Source (N)
2946          then
2947             if Try_Object_Operation (N) then
2948                return;
2949             else
2950                Error_Msg_N
2951                  ("invalid dereference of a remote access-to-class-wide value",
2952                   N);
2953             end if;
2954
2955          --  Normal case of selected component applied to access type
2956
2957          else
2958             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2959
2960             if Is_Entity_Name (Name) then
2961                Pent := Entity (Name);
2962             elsif Nkind (Name) = N_Selected_Component
2963               and then Is_Entity_Name (Selector_Name (Name))
2964             then
2965                Pent := Entity (Selector_Name (Name));
2966             end if;
2967
2968             Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
2969          end if;
2970
2971       --  If we have an explicit dereference of a remote access-to-class-wide
2972       --  value, then issue an error (see RM-E.2.2(16/1)). However we first
2973       --  have to check for the case of a prefix that is a controlling operand
2974       --  of a prefixed dispatching call, as the dereference is legal in that
2975       --  case. Normally this condition is checked in Validate_Remote_Access_
2976       --  To_Class_Wide_Type, but we have to defer the checking for selected
2977       --  component prefixes because of the prefixed dispatching call case.
2978       --  Note that implicit dereferences are checked for this just above.
2979
2980       elsif Nkind (Name) = N_Explicit_Dereference
2981         and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
2982         and then Comes_From_Source (N)
2983       then
2984          if Try_Object_Operation (N) then
2985             return;
2986          else
2987             Error_Msg_N
2988               ("invalid dereference of a remote access-to-class-wide value",
2989                N);
2990          end if;
2991       end if;
2992
2993       --  (Ada 2005): if the prefix is the limited view of a type, and
2994       --  the context already includes the full view, use the full view
2995       --  in what follows, either to retrieve a component of to find
2996       --  a primitive operation. If the prefix is an explicit dereference,
2997       --  set the type of the prefix to reflect this transformation.
2998       --  If the non-limited view is itself an incomplete type, get the
2999       --  full view if available.
3000
3001       if Is_Incomplete_Type (Prefix_Type)
3002         and then From_With_Type (Prefix_Type)
3003         and then Present (Non_Limited_View (Prefix_Type))
3004       then
3005          Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type));
3006
3007          if Nkind (N) = N_Explicit_Dereference then
3008             Set_Etype (Prefix (N), Prefix_Type);
3009          end if;
3010
3011       elsif Ekind (Prefix_Type) = E_Class_Wide_Type
3012         and then From_With_Type (Prefix_Type)
3013         and then Present (Non_Limited_View (Etype (Prefix_Type)))
3014       then
3015          Prefix_Type :=
3016            Class_Wide_Type (Non_Limited_View (Etype (Prefix_Type)));
3017
3018          if Nkind (N) = N_Explicit_Dereference then
3019             Set_Etype (Prefix (N), Prefix_Type);
3020          end if;
3021       end if;
3022
3023       if Ekind (Prefix_Type) = E_Private_Subtype then
3024          Prefix_Type := Base_Type (Prefix_Type);
3025       end if;
3026
3027       Type_To_Use := Prefix_Type;
3028
3029       --  For class-wide types, use the entity list of the root type. This
3030       --  indirection is specially important for private extensions because
3031       --  only the root type get switched (not the class-wide type).
3032
3033       if Is_Class_Wide_Type (Prefix_Type) then
3034          Type_To_Use := Root_Type (Prefix_Type);
3035       end if;
3036
3037       Comp := First_Entity (Type_To_Use);
3038
3039       --  If the selector has an original discriminant, the node appears in
3040       --  an instance. Replace the discriminant with the corresponding one
3041       --  in the current discriminated type. For nested generics, this must
3042       --  be done transitively, so note the new original discriminant.
3043
3044       if Nkind (Sel) = N_Identifier
3045         and then Present (Original_Discriminant (Sel))
3046       then
3047          Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
3048
3049          --  Mark entity before rewriting, for completeness and because
3050          --  subsequent semantic checks might examine the original node.
3051
3052          Set_Entity (Sel, Comp);
3053          Rewrite (Selector_Name (N),
3054            New_Occurrence_Of (Comp, Sloc (N)));
3055          Set_Original_Discriminant (Selector_Name (N), Comp);
3056          Set_Etype (N, Etype (Comp));
3057
3058          if Is_Access_Type (Etype (Name)) then
3059             Insert_Explicit_Dereference (Name);
3060             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3061          end if;
3062
3063       elsif Is_Record_Type (Prefix_Type) then
3064
3065          --  Find component with given name
3066
3067          while Present (Comp) loop
3068             if Chars (Comp) = Chars (Sel)
3069               and then Is_Visible_Component (Comp)
3070             then
3071                Set_Entity_With_Style_Check (Sel, Comp);
3072                Set_Etype (Sel, Etype (Comp));
3073
3074                if Ekind (Comp) = E_Discriminant then
3075                   if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
3076                      Error_Msg_N
3077                        ("cannot reference discriminant of Unchecked_Union",
3078                         Sel);
3079                   end if;
3080
3081                   if Is_Generic_Type (Prefix_Type)
3082                        or else
3083                      Is_Generic_Type (Root_Type (Prefix_Type))
3084                   then
3085                      Set_Original_Discriminant (Sel, Comp);
3086                   end if;
3087                end if;
3088
3089                --  Resolve the prefix early otherwise it is not possible to
3090                --  build the actual subtype of the component: it may need
3091                --  to duplicate this prefix and duplication is only allowed
3092                --  on fully resolved expressions.
3093
3094                Resolve (Name);
3095
3096                --  Ada 2005 (AI-50217): Check wrong use of incomplete types or
3097                --  subtypes in a package specification.
3098                --  Example:
3099
3100                --    limited with Pkg;
3101                --    package Pkg is
3102                --       type Acc_Inc is access Pkg.T;
3103                --       X : Acc_Inc;
3104                --       N : Natural := X.all.Comp;  --  ERROR, limited view
3105                --    end Pkg;                       --  Comp is not visible
3106
3107                if Nkind (Name) = N_Explicit_Dereference
3108                  and then From_With_Type (Etype (Prefix (Name)))
3109                  and then not Is_Potentially_Use_Visible (Etype (Name))
3110                  and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) =
3111                             N_Package_Specification
3112                then
3113                   Error_Msg_NE
3114                     ("premature usage of incomplete}", Prefix (Name),
3115                      Etype (Prefix (Name)));
3116                end if;
3117
3118                --  We never need an actual subtype for the case of a selection
3119                --  for a indexed component of a non-packed array, since in
3120                --  this case gigi generates all the checks and can find the
3121                --  necessary bounds information.
3122
3123                --  We also do not need an actual subtype for the case of
3124                --  a first, last, length, or range attribute applied to a
3125                --  non-packed array, since gigi can again get the bounds in
3126                --  these cases (gigi cannot handle the packed case, since it
3127                --  has the bounds of the packed array type, not the original
3128                --  bounds of the type). However, if the prefix is itself a
3129                --  selected component, as in a.b.c (i), gigi may regard a.b.c
3130                --  as a dynamic-sized temporary, so we do generate an actual
3131                --  subtype for this case.
3132
3133                Parent_N := Parent (N);
3134
3135                if not Is_Packed (Etype (Comp))
3136                  and then
3137                    ((Nkind (Parent_N) = N_Indexed_Component
3138                        and then Nkind (Name) /= N_Selected_Component)
3139                      or else
3140                       (Nkind (Parent_N) = N_Attribute_Reference
3141                          and then (Attribute_Name (Parent_N) = Name_First
3142                                      or else
3143                                    Attribute_Name (Parent_N) = Name_Last
3144                                      or else
3145                                    Attribute_Name (Parent_N) = Name_Length
3146                                      or else
3147                                    Attribute_Name (Parent_N) = Name_Range)))
3148                then
3149                   Set_Etype (N, Etype (Comp));
3150
3151                --  If full analysis is not enabled, we do not generate an
3152                --  actual subtype, because in the absence of expansion
3153                --  reference to a formal of a protected type, for example,
3154                --  will not be properly transformed, and will lead to
3155                --  out-of-scope references in gigi.
3156
3157                --  In all other cases, we currently build an actual subtype.
3158                --  It seems likely that many of these cases can be avoided,
3159                --  but right now, the front end makes direct references to the
3160                --  bounds (e.g. in generating a length check), and if we do
3161                --  not make an actual subtype, we end up getting a direct
3162                --  reference to a discriminant, which will not do.
3163
3164                elsif Full_Analysis then
3165                   Act_Decl :=
3166                     Build_Actual_Subtype_Of_Component (Etype (Comp), N);
3167                   Insert_Action (N, Act_Decl);
3168
3169                   if No (Act_Decl) then
3170                      Set_Etype (N, Etype (Comp));
3171
3172                   else
3173                      --  Component type depends on discriminants. Enter the
3174                      --  main attributes of the subtype.
3175
3176                      declare
3177                         Subt : constant Entity_Id :=
3178                                  Defining_Identifier (Act_Decl);
3179
3180                      begin
3181                         Set_Etype (Subt, Base_Type (Etype (Comp)));
3182                         Set_Ekind (Subt, Ekind (Etype (Comp)));
3183                         Set_Etype (N, Subt);
3184                      end;
3185                   end if;
3186
3187                --  If Full_Analysis not enabled, just set the Etype
3188
3189                else
3190                   Set_Etype (N, Etype (Comp));
3191                end if;
3192
3193                return;
3194             end if;
3195
3196             --  If the prefix is a private extension, check only the visible
3197             --  components of the partial view. This must include the tag,
3198             --  wich can appear in expanded code in a tag check.
3199
3200             if Ekind (Type_To_Use) = E_Record_Type_With_Private
3201               and then  Chars (Selector_Name (N)) /= Name_uTag
3202             then
3203                exit when Comp = Last_Entity (Type_To_Use);
3204             end if;
3205
3206             Next_Entity (Comp);
3207          end loop;
3208
3209          --  Ada 2005 (AI-252): The selected component can be interpreted as
3210          --  a prefixed view of a subprogram. Depending on the context, this is
3211          --  either a name that can appear in a renaming declaration, or part
3212          --  of an enclosing call given in prefix form.
3213
3214          --  Ada 2005 (AI05-0030): In the case of dispatching requeue, the
3215          --  selected component should resolve to a name.
3216
3217          if Ada_Version >= Ada_05
3218            and then Is_Tagged_Type (Prefix_Type)
3219            and then not Is_Concurrent_Type (Prefix_Type)
3220          then
3221             if Nkind (Parent (N)) = N_Generic_Association
3222               or else Nkind (Parent (N)) = N_Requeue_Statement
3223               or else Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
3224             then
3225                if Find_Primitive_Operation (N) then
3226                   return;
3227                end if;
3228
3229             elsif Try_Object_Operation (N) then
3230                return;
3231             end if;
3232
3233             --  If the transformation fails, it will be necessary to redo the
3234             --  analysis with all errors enabled, to indicate candidate
3235             --  interpretations and reasons for each failure ???
3236
3237          end if;
3238
3239       elsif Is_Private_Type (Prefix_Type) then
3240
3241          --  Allow access only to discriminants of the type. If the type has
3242          --  no full view, gigi uses the parent type for the components, so we
3243          --  do the same here.
3244
3245          if No (Full_View (Prefix_Type)) then
3246             Type_To_Use := Root_Type (Base_Type (Prefix_Type));
3247             Comp := First_Entity (Type_To_Use);
3248          end if;
3249
3250          while Present (Comp) loop
3251             if Chars (Comp) = Chars (Sel) then
3252                if Ekind (Comp) = E_Discriminant then
3253                   Set_Entity_With_Style_Check (Sel, Comp);
3254                   Generate_Reference (Comp, Sel);
3255
3256                   Set_Etype (Sel, Etype (Comp));
3257                   Set_Etype (N,   Etype (Comp));
3258
3259                   if Is_Generic_Type (Prefix_Type)
3260                     or else Is_Generic_Type (Root_Type (Prefix_Type))
3261                   then
3262                      Set_Original_Discriminant (Sel, Comp);
3263                   end if;
3264
3265                --  Before declararing an error, check whether this is tagged
3266                --  private type and a call to a primitive operation.
3267
3268                elsif Ada_Version >= Ada_05
3269                  and then Is_Tagged_Type (Prefix_Type)
3270                  and then Try_Object_Operation (N)
3271                then
3272                   return;
3273
3274                else
3275                   Error_Msg_NE
3276                     ("invisible selector for }",
3277                      N, First_Subtype (Prefix_Type));
3278                   Set_Entity (Sel, Any_Id);
3279                   Set_Etype (N, Any_Type);
3280                end if;
3281
3282                return;
3283             end if;
3284
3285             Next_Entity (Comp);
3286          end loop;
3287
3288       elsif Is_Concurrent_Type (Prefix_Type) then
3289
3290          --  Find visible operation with given name. For a protected type,
3291          --  the possible candidates are discriminants, entries or protected
3292          --  procedures. For a task type, the set can only include entries or
3293          --  discriminants if the task type is not an enclosing scope. If it
3294          --  is an enclosing scope (e.g. in an inner task) then all entities
3295          --  are visible, but the prefix must denote the enclosing scope, i.e.
3296          --  can only be a direct name or an expanded name.
3297
3298          Set_Etype (Sel, Any_Type);
3299          In_Scope := In_Open_Scopes (Prefix_Type);
3300
3301          while Present (Comp) loop
3302             if Chars (Comp) = Chars (Sel) then
3303                if Is_Overloadable (Comp) then
3304                   Add_One_Interp (Sel, Comp, Etype (Comp));
3305
3306                   --  If the prefix is tagged, the correct interpretation may
3307                   --  lie in the primitive or class-wide operations of the
3308                   --  type. Perform a simple conformance check to determine
3309                   --  whether Try_Object_Operation should be invoked even if
3310                   --  a visible entity is found.
3311
3312                   if Is_Tagged_Type (Prefix_Type)
3313                     and then
3314                       Nkind_In (Parent (N), N_Procedure_Call_Statement,
3315                                             N_Function_Call,
3316                                             N_Indexed_Component)
3317                     and then Has_Mode_Conformant_Spec (Comp)
3318                   then
3319                      Has_Candidate := True;
3320                   end if;
3321
3322                elsif Ekind (Comp) = E_Discriminant
3323                  or else Ekind (Comp) = E_Entry_Family
3324                  or else (In_Scope
3325                    and then Is_Entity_Name (Name))
3326                then
3327                   Set_Entity_With_Style_Check (Sel, Comp);
3328                   Generate_Reference (Comp, Sel);
3329
3330                else
3331                   goto Next_Comp;
3332                end if;
3333
3334                Set_Etype (Sel, Etype (Comp));
3335                Set_Etype (N,   Etype (Comp));
3336
3337                if Ekind (Comp) = E_Discriminant then
3338                   Set_Original_Discriminant (Sel, Comp);
3339                end if;
3340
3341                --  For access type case, introduce explicit deference for more
3342                --  uniform treatment of entry calls.
3343
3344                if Is_Access_Type (Etype (Name)) then
3345                   Insert_Explicit_Dereference (Name);
3346                   Error_Msg_NW
3347                     (Warn_On_Dereference, "?implicit dereference", N);
3348                end if;
3349             end if;
3350
3351             <<Next_Comp>>
3352                Next_Entity (Comp);
3353                exit when not In_Scope
3354                  and then
3355                    Comp = First_Private_Entity (Base_Type (Prefix_Type));
3356          end loop;
3357
3358          --  If there is no visible entity with the given name or none of the
3359          --  visible entities are plausible interpretations, check whether
3360          --  there is some other primitive operation with that name.
3361
3362          if Ada_Version >= Ada_05
3363            and then Is_Tagged_Type (Prefix_Type)
3364          then
3365             if (Etype (N) = Any_Type
3366                   or else not Has_Candidate)
3367               and then Try_Object_Operation (N)
3368             then
3369                return;
3370
3371             --  If the context is not syntactically a procedure call, it
3372             --  may be a call to a primitive function declared outside of
3373             --  the synchronized type.
3374
3375             --  If the context is a procedure call, there might still be
3376             --  an overloading between an entry and a primitive procedure
3377             --  declared outside of the synchronized type, called in prefix
3378             --  notation. This is harder to disambiguate because in one case
3379             --  the controlling formal is implicit ???
3380
3381             elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
3382               and then Nkind (Parent (N)) /= N_Indexed_Component
3383               and then Try_Object_Operation (N)
3384             then
3385                return;
3386             end if;
3387          end if;
3388
3389          Set_Is_Overloaded (N, Is_Overloaded (Sel));
3390
3391       else
3392          --  Invalid prefix
3393
3394          Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
3395       end if;
3396
3397       --  If N still has no type, the component is not defined in the prefix
3398
3399       if Etype (N) = Any_Type then
3400
3401          --  If the prefix is a single concurrent object, use its name in the
3402          --  error message, rather than that of its anonymous type.
3403
3404          if Is_Concurrent_Type (Prefix_Type)
3405            and then Is_Internal_Name (Chars (Prefix_Type))
3406            and then not Is_Derived_Type (Prefix_Type)
3407            and then Is_Entity_Name (Name)
3408          then
3409
3410             Error_Msg_Node_2 := Entity (Name);
3411             Error_Msg_NE ("no selector& for&", N, Sel);
3412
3413             Check_Misspelled_Selector (Type_To_Use, Sel);
3414
3415          elsif Is_Generic_Type (Prefix_Type)
3416            and then Ekind (Prefix_Type) = E_Record_Type_With_Private
3417            and then Prefix_Type /= Etype (Prefix_Type)
3418            and then Is_Record_Type (Etype (Prefix_Type))
3419          then
3420             --  If this is a derived formal type, the parent may have
3421             --  different visibility at this point. Try for an inherited
3422             --  component before reporting an error.
3423
3424             Set_Etype (Prefix (N), Etype (Prefix_Type));
3425             Analyze_Selected_Component (N);
3426             return;
3427
3428          elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
3429            and then Is_Generic_Actual_Type (Prefix_Type)
3430            and then Present (Full_View (Prefix_Type))
3431          then
3432             --  Similarly, if this the actual for a formal derived type, the
3433             --  component inherited from the generic parent may not be visible
3434             --  in the actual, but the selected component is legal.
3435
3436             declare
3437                Comp : Entity_Id;
3438
3439             begin
3440                Comp :=
3441                  First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
3442                while Present (Comp) loop
3443                   if Chars (Comp) = Chars (Sel) then
3444                      Set_Entity_With_Style_Check (Sel, Comp);
3445                      Set_Etype (Sel, Etype (Comp));
3446                      Set_Etype (N,   Etype (Comp));
3447                      return;
3448                   end if;
3449
3450                   Next_Component (Comp);
3451                end loop;
3452
3453                pragma Assert (Etype (N) /= Any_Type);
3454             end;
3455
3456          else
3457             if Ekind (Prefix_Type) = E_Record_Subtype then
3458
3459                --  Check whether this is a component of the base type
3460                --  which is absent from a statically constrained subtype.
3461                --  This will raise constraint error at run-time, but is
3462                --  not a compile-time error. When the selector is illegal
3463                --  for base type as well fall through and generate a
3464                --  compilation error anyway.
3465
3466                Comp := First_Component (Base_Type (Prefix_Type));
3467                while Present (Comp) loop
3468                   if Chars (Comp) = Chars (Sel)
3469                     and then Is_Visible_Component (Comp)
3470                   then
3471                      Set_Entity_With_Style_Check (Sel, Comp);
3472                      Generate_Reference (Comp, Sel);
3473                      Set_Etype (Sel, Etype (Comp));
3474                      Set_Etype (N,   Etype (Comp));
3475
3476                      --  Emit appropriate message. Gigi will replace the
3477                      --  node subsequently with the appropriate Raise.
3478
3479                      Apply_Compile_Time_Constraint_Error
3480                        (N, "component not present in }?",
3481                         CE_Discriminant_Check_Failed,
3482                         Ent => Prefix_Type, Rep => False);
3483                      Set_Raises_Constraint_Error (N);
3484                      return;
3485                   end if;
3486
3487                   Next_Component (Comp);
3488                end loop;
3489
3490             end if;
3491
3492             Error_Msg_Node_2 := First_Subtype (Prefix_Type);
3493             Error_Msg_NE ("no selector& for}", N, Sel);
3494
3495             Check_Misspelled_Selector (Type_To_Use, Sel);
3496
3497          end if;
3498
3499          Set_Entity (Sel, Any_Id);
3500          Set_Etype (Sel, Any_Type);
3501       end if;
3502    end Analyze_Selected_Component;
3503
3504    ---------------------------
3505    -- Analyze_Short_Circuit --
3506    ---------------------------
3507
3508    procedure Analyze_Short_Circuit (N : Node_Id) is
3509       L   : constant Node_Id := Left_Opnd  (N);
3510       R   : constant Node_Id := Right_Opnd (N);
3511       Ind : Interp_Index;
3512       It  : Interp;
3513
3514    begin
3515       Analyze_Expression (L);
3516       Analyze_Expression (R);
3517       Set_Etype (N, Any_Type);
3518
3519       if not Is_Overloaded (L) then
3520          if Root_Type (Etype (L)) = Standard_Boolean
3521            and then Has_Compatible_Type (R, Etype (L))
3522          then
3523             Add_One_Interp (N, Etype (L), Etype (L));
3524          end if;
3525
3526       else
3527          Get_First_Interp (L, Ind, It);
3528          while Present (It.Typ) loop
3529             if Root_Type (It.Typ) = Standard_Boolean
3530               and then Has_Compatible_Type (R, It.Typ)
3531             then
3532                Add_One_Interp (N, It.Typ, It.Typ);
3533             end if;
3534
3535             Get_Next_Interp (Ind, It);
3536          end loop;
3537       end if;
3538
3539       --  Here we have failed to find an interpretation. Clearly we know that
3540       --  it is not the case that both operands can have an interpretation of
3541       --  Boolean, but this is by far the most likely intended interpretation.
3542       --  So we simply resolve both operands as Booleans, and at least one of
3543       --  these resolutions will generate an error message, and we do not need
3544       --  to give another error message on the short circuit operation itself.
3545
3546       if Etype (N) = Any_Type then
3547          Resolve (L, Standard_Boolean);
3548          Resolve (R, Standard_Boolean);
3549          Set_Etype (N, Standard_Boolean);
3550       end if;
3551    end Analyze_Short_Circuit;
3552
3553    -------------------
3554    -- Analyze_Slice --
3555    -------------------
3556
3557    procedure Analyze_Slice (N : Node_Id) is
3558       P          : constant Node_Id := Prefix (N);
3559       D          : constant Node_Id := Discrete_Range (N);
3560       Array_Type : Entity_Id;
3561
3562       procedure Analyze_Overloaded_Slice;
3563       --  If the prefix is overloaded, select those interpretations that
3564       --  yield a one-dimensional array type.
3565
3566       ------------------------------
3567       -- Analyze_Overloaded_Slice --
3568       ------------------------------
3569
3570       procedure Analyze_Overloaded_Slice is
3571          I   : Interp_Index;
3572          It  : Interp;
3573          Typ : Entity_Id;
3574
3575       begin
3576          Set_Etype (N, Any_Type);
3577
3578          Get_First_Interp (P, I, It);
3579          while Present (It.Nam) loop
3580             Typ := It.Typ;
3581
3582             if Is_Access_Type (Typ) then
3583                Typ := Designated_Type (Typ);
3584                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3585             end if;
3586
3587             if Is_Array_Type (Typ)
3588               and then Number_Dimensions (Typ) = 1
3589               and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
3590             then
3591                Add_One_Interp (N, Typ, Typ);
3592             end if;
3593
3594             Get_Next_Interp (I, It);
3595          end loop;
3596
3597          if Etype (N) = Any_Type then
3598             Error_Msg_N ("expect array type in prefix of slice",  N);
3599          end if;
3600       end Analyze_Overloaded_Slice;
3601
3602    --  Start of processing for Analyze_Slice
3603
3604    begin
3605       Analyze (P);
3606       Analyze (D);
3607
3608       if Is_Overloaded (P) then
3609          Analyze_Overloaded_Slice;
3610
3611       else
3612          Array_Type := Etype (P);
3613          Set_Etype (N, Any_Type);
3614
3615          if Is_Access_Type (Array_Type) then
3616             Array_Type := Designated_Type (Array_Type);
3617             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3618          end if;
3619
3620          if not Is_Array_Type (Array_Type) then
3621             Wrong_Type (P, Any_Array);
3622
3623          elsif Number_Dimensions (Array_Type) > 1 then
3624             Error_Msg_N
3625               ("type is not one-dimensional array in slice prefix", N);
3626
3627          elsif not
3628            Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
3629          then
3630             Wrong_Type (D, Etype (First_Index (Array_Type)));
3631
3632          else
3633             Set_Etype (N, Array_Type);
3634          end if;
3635       end if;
3636    end Analyze_Slice;
3637
3638    -----------------------------
3639    -- Analyze_Type_Conversion --
3640    -----------------------------
3641
3642    procedure Analyze_Type_Conversion (N : Node_Id) is
3643       Expr : constant Node_Id := Expression (N);
3644       T    : Entity_Id;
3645
3646    begin
3647       --  If Conversion_OK is set, then the Etype is already set, and the
3648       --  only processing required is to analyze the expression. This is
3649       --  used to construct certain "illegal" conversions which are not
3650       --  allowed by Ada semantics, but can be handled OK by Gigi, see
3651       --  Sinfo for further details.
3652
3653       if Conversion_OK (N) then
3654          Analyze (Expr);
3655          return;
3656       end if;
3657
3658       --  Otherwise full type analysis is required, as well as some semantic
3659       --  checks to make sure the argument of the conversion is appropriate.
3660
3661       Find_Type (Subtype_Mark (N));
3662       T := Entity (Subtype_Mark (N));
3663       Set_Etype (N, T);
3664       Check_Fully_Declared (T, N);
3665       Analyze_Expression (Expr);
3666       Validate_Remote_Type_Type_Conversion (N);
3667
3668       --  Only remaining step is validity checks on the argument. These
3669       --  are skipped if the conversion does not come from the source.
3670
3671       if not Comes_From_Source (N) then
3672          return;
3673
3674       --  If there was an error in a generic unit, no need to replicate the
3675       --  error message. Conversely, constant-folding in the generic may
3676       --  transform the argument of a conversion into a string literal, which
3677       --  is legal. Therefore the following tests are not performed in an
3678       --  instance.
3679
3680       elsif In_Instance then
3681          return;
3682
3683       elsif Nkind (Expr) = N_Null then
3684          Error_Msg_N ("argument of conversion cannot be null", N);
3685          Error_Msg_N ("\use qualified expression instead", N);
3686          Set_Etype (N, Any_Type);
3687
3688       elsif Nkind (Expr) = N_Aggregate then
3689          Error_Msg_N ("argument of conversion cannot be aggregate", N);
3690          Error_Msg_N ("\use qualified expression instead", N);
3691
3692       elsif Nkind (Expr) = N_Allocator then
3693          Error_Msg_N ("argument of conversion cannot be an allocator", N);
3694          Error_Msg_N ("\use qualified expression instead", N);
3695
3696       elsif Nkind (Expr) = N_String_Literal then
3697          Error_Msg_N ("argument of conversion cannot be string literal", N);
3698          Error_Msg_N ("\use qualified expression instead", N);
3699
3700       elsif Nkind (Expr) = N_Character_Literal then
3701          if Ada_Version = Ada_83 then
3702             Resolve (Expr, T);
3703          else
3704             Error_Msg_N ("argument of conversion cannot be character literal",
3705               N);
3706             Error_Msg_N ("\use qualified expression instead", N);
3707          end if;
3708
3709       elsif Nkind (Expr) = N_Attribute_Reference
3710         and then
3711           (Attribute_Name (Expr) = Name_Access            or else
3712            Attribute_Name (Expr) = Name_Unchecked_Access  or else
3713            Attribute_Name (Expr) = Name_Unrestricted_Access)
3714       then
3715          Error_Msg_N ("argument of conversion cannot be access", N);
3716          Error_Msg_N ("\use qualified expression instead", N);
3717       end if;
3718    end Analyze_Type_Conversion;
3719
3720    ----------------------
3721    -- Analyze_Unary_Op --
3722    ----------------------
3723
3724    procedure Analyze_Unary_Op (N : Node_Id) is
3725       R     : constant Node_Id := Right_Opnd (N);
3726       Op_Id : Entity_Id := Entity (N);
3727
3728    begin
3729       Set_Etype (N, Any_Type);
3730       Candidate_Type := Empty;
3731
3732       Analyze_Expression (R);
3733
3734       if Present (Op_Id) then
3735          if Ekind (Op_Id) = E_Operator then
3736             Find_Unary_Types (R, Op_Id,  N);
3737          else
3738             Add_One_Interp (N, Op_Id, Etype (Op_Id));
3739          end if;
3740
3741       else
3742          Op_Id := Get_Name_Entity_Id (Chars (N));
3743          while Present (Op_Id) loop
3744             if Ekind (Op_Id) = E_Operator then
3745                if No (Next_Entity (First_Entity (Op_Id))) then
3746                   Find_Unary_Types (R, Op_Id,  N);
3747                end if;
3748
3749             elsif Is_Overloadable (Op_Id) then
3750                Analyze_User_Defined_Unary_Op (N, Op_Id);
3751             end if;
3752
3753             Op_Id := Homonym (Op_Id);
3754          end loop;
3755       end if;
3756
3757       Operator_Check (N);
3758    end Analyze_Unary_Op;
3759
3760    ----------------------------------
3761    -- Analyze_Unchecked_Expression --
3762    ----------------------------------
3763
3764    procedure Analyze_Unchecked_Expression (N : Node_Id) is
3765    begin
3766       Analyze (Expression (N), Suppress => All_Checks);
3767       Set_Etype (N, Etype (Expression (N)));
3768       Save_Interps (Expression (N), N);
3769    end Analyze_Unchecked_Expression;
3770
3771    ---------------------------------------
3772    -- Analyze_Unchecked_Type_Conversion --
3773    ---------------------------------------
3774
3775    procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
3776    begin
3777       Find_Type (Subtype_Mark (N));
3778       Analyze_Expression (Expression (N));
3779       Set_Etype (N, Entity (Subtype_Mark (N)));
3780    end Analyze_Unchecked_Type_Conversion;
3781
3782    ------------------------------------
3783    -- Analyze_User_Defined_Binary_Op --
3784    ------------------------------------
3785
3786    procedure Analyze_User_Defined_Binary_Op
3787      (N     : Node_Id;
3788       Op_Id : Entity_Id)
3789    is
3790    begin
3791       --  Only do analysis if the operator Comes_From_Source, since otherwise
3792       --  the operator was generated by the expander, and all such operators
3793       --  always refer to the operators in package Standard.
3794
3795       if Comes_From_Source (N) then
3796          declare
3797             F1 : constant Entity_Id := First_Formal (Op_Id);
3798             F2 : constant Entity_Id := Next_Formal (F1);
3799
3800          begin
3801             --  Verify that Op_Id is a visible binary function. Note that since
3802             --  we know Op_Id is overloaded, potentially use visible means use
3803             --  visible for sure (RM 9.4(11)).
3804
3805             if Ekind (Op_Id) = E_Function
3806               and then Present (F2)
3807               and then (Is_Immediately_Visible (Op_Id)
3808                          or else Is_Potentially_Use_Visible (Op_Id))
3809               and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
3810               and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
3811             then
3812                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3813
3814                if Debug_Flag_E then
3815                   Write_Str ("user defined operator ");
3816                   Write_Name (Chars (Op_Id));
3817                   Write_Str (" on node ");
3818                   Write_Int (Int (N));
3819                   Write_Eol;
3820                end if;
3821             end if;
3822          end;
3823       end if;
3824    end Analyze_User_Defined_Binary_Op;
3825
3826    -----------------------------------
3827    -- Analyze_User_Defined_Unary_Op --
3828    -----------------------------------
3829
3830    procedure Analyze_User_Defined_Unary_Op
3831      (N     : Node_Id;
3832       Op_Id : Entity_Id)
3833    is
3834    begin
3835       --  Only do analysis if the operator Comes_From_Source, since otherwise
3836       --  the operator was generated by the expander, and all such operators
3837       --  always refer to the operators in package Standard.
3838
3839       if Comes_From_Source (N) then
3840          declare
3841             F : constant Entity_Id := First_Formal (Op_Id);
3842
3843          begin
3844             --  Verify that Op_Id is a visible unary function. Note that since
3845             --  we know Op_Id is overloaded, potentially use visible means use
3846             --  visible for sure (RM 9.4(11)).
3847
3848             if Ekind (Op_Id) = E_Function
3849               and then No (Next_Formal (F))
3850               and then (Is_Immediately_Visible (Op_Id)
3851                          or else Is_Potentially_Use_Visible (Op_Id))
3852               and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
3853             then
3854                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3855             end if;
3856          end;
3857       end if;
3858    end Analyze_User_Defined_Unary_Op;
3859
3860    ---------------------------
3861    -- Check_Arithmetic_Pair --
3862    ---------------------------
3863
3864    procedure Check_Arithmetic_Pair
3865      (T1, T2 : Entity_Id;
3866       Op_Id  : Entity_Id;
3867       N      : Node_Id)
3868    is
3869       Op_Name : constant Name_Id := Chars (Op_Id);
3870
3871       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
3872       --  Check whether the fixed-point type Typ has a user-defined operator
3873       --  (multiplication or division) that should hide the corresponding
3874       --  predefined operator. Used to implement Ada 2005 AI-264, to make
3875       --  such operators more visible and therefore useful.
3876
3877       --  If the name of the operation is an expanded name with prefix
3878       --  Standard, the predefined universal fixed operator is available,
3879       --  as specified by AI-420 (RM 4.5.5 (19.1/2)).
3880
3881       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
3882       --  Get specific type (i.e. non-universal type if there is one)
3883
3884       ------------------
3885       -- Has_Fixed_Op --
3886       ------------------
3887
3888       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
3889          Bas : constant Entity_Id := Base_Type (Typ);
3890          Ent : Entity_Id;
3891          F1  : Entity_Id;
3892          F2  : Entity_Id;
3893
3894       begin
3895          --  If the universal_fixed operation is given explicitly the rule
3896          --  concerning primitive operations of the type do not apply.
3897
3898          if Nkind (N) = N_Function_Call
3899            and then Nkind (Name (N)) = N_Expanded_Name
3900            and then Entity (Prefix (Name (N))) = Standard_Standard
3901          then
3902             return False;
3903          end if;
3904
3905          --  The operation is treated as primitive if it is declared in the
3906          --  same scope as the type, and therefore on the same entity chain.
3907
3908          Ent := Next_Entity (Typ);
3909          while Present (Ent) loop
3910             if Chars (Ent) = Chars (Op) then
3911                F1 := First_Formal (Ent);
3912                F2 := Next_Formal (F1);
3913
3914                --  The operation counts as primitive if either operand or
3915                --  result are of the given base type, and both operands are
3916                --  fixed point types.
3917
3918                if (Base_Type (Etype (F1)) = Bas
3919                     and then Is_Fixed_Point_Type (Etype (F2)))
3920
3921                  or else
3922                    (Base_Type (Etype (F2)) = Bas
3923                      and then Is_Fixed_Point_Type (Etype (F1)))
3924
3925                  or else
3926                    (Base_Type (Etype (Ent)) = Bas
3927                      and then Is_Fixed_Point_Type (Etype (F1))
3928                      and then Is_Fixed_Point_Type (Etype (F2)))
3929                then
3930                   return True;
3931                end if;
3932             end if;
3933
3934             Next_Entity (Ent);
3935          end loop;
3936
3937          return False;
3938       end Has_Fixed_Op;
3939
3940       -------------------
3941       -- Specific_Type --
3942       -------------------
3943
3944       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
3945       begin
3946          if T1 = Universal_Integer or else T1 = Universal_Real then
3947             return Base_Type (T2);
3948          else
3949             return Base_Type (T1);
3950          end if;
3951       end Specific_Type;
3952
3953    --  Start of processing for Check_Arithmetic_Pair
3954
3955    begin
3956       if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
3957
3958          if Is_Numeric_Type (T1)
3959            and then Is_Numeric_Type (T2)
3960            and then (Covers (T1 => T1, T2 => T2)
3961                        or else
3962                      Covers (T1 => T2, T2 => T1))
3963          then
3964             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3965          end if;
3966
3967       elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
3968
3969          if Is_Fixed_Point_Type (T1)
3970            and then (Is_Fixed_Point_Type (T2)
3971                        or else T2 = Universal_Real)
3972          then
3973             --  If Treat_Fixed_As_Integer is set then the Etype is already set
3974             --  and no further processing is required (this is the case of an
3975             --  operator constructed by Exp_Fixd for a fixed point operation)
3976             --  Otherwise add one interpretation with universal fixed result
3977             --  If the operator is given in  functional notation, it comes
3978             --  from source and Fixed_As_Integer cannot apply.
3979
3980             if (Nkind (N) not in N_Op
3981                  or else not Treat_Fixed_As_Integer (N))
3982               and then
3983                 (not Has_Fixed_Op (T1, Op_Id)
3984                   or else Nkind (Parent (N)) = N_Type_Conversion)
3985             then
3986                Add_One_Interp (N, Op_Id, Universal_Fixed);
3987             end if;
3988
3989          elsif Is_Fixed_Point_Type (T2)
3990            and then (Nkind (N) not in N_Op
3991                       or else not Treat_Fixed_As_Integer (N))
3992            and then T1 = Universal_Real
3993            and then
3994              (not Has_Fixed_Op (T1, Op_Id)
3995                or else Nkind (Parent (N)) = N_Type_Conversion)
3996          then
3997             Add_One_Interp (N, Op_Id, Universal_Fixed);
3998
3999          elsif Is_Numeric_Type (T1)
4000            and then Is_Numeric_Type (T2)
4001            and then (Covers (T1 => T1, T2 => T2)
4002                        or else
4003                      Covers (T1 => T2, T2 => T1))
4004          then
4005             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
4006
4007          elsif Is_Fixed_Point_Type (T1)
4008            and then (Base_Type (T2) = Base_Type (Standard_Integer)
4009                        or else T2 = Universal_Integer)
4010          then
4011             Add_One_Interp (N, Op_Id, T1);
4012
4013          elsif T2 = Universal_Real
4014            and then Base_Type (T1) = Base_Type (Standard_Integer)
4015            and then Op_Name = Name_Op_Multiply
4016          then
4017             Add_One_Interp (N, Op_Id, Any_Fixed);
4018
4019          elsif T1 = Universal_Real
4020            and then Base_Type (T2) = Base_Type (Standard_Integer)
4021          then
4022             Add_One_Interp (N, Op_Id, Any_Fixed);
4023
4024          elsif Is_Fixed_Point_Type (T2)
4025            and then (Base_Type (T1) = Base_Type (Standard_Integer)
4026                        or else T1 = Universal_Integer)
4027            and then Op_Name = Name_Op_Multiply
4028          then
4029             Add_One_Interp (N, Op_Id, T2);
4030
4031          elsif T1 = Universal_Real and then T2 = Universal_Integer then
4032             Add_One_Interp (N, Op_Id, T1);
4033
4034          elsif T2 = Universal_Real
4035            and then T1 = Universal_Integer
4036            and then Op_Name = Name_Op_Multiply
4037          then
4038             Add_One_Interp (N, Op_Id, T2);
4039          end if;
4040
4041       elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
4042
4043          --  Note: The fixed-point operands case with Treat_Fixed_As_Integer
4044          --  set does not require any special processing, since the Etype is
4045          --  already set (case of operation constructed by Exp_Fixed).
4046
4047          if Is_Integer_Type (T1)
4048            and then (Covers (T1 => T1, T2 => T2)
4049                        or else
4050                      Covers (T1 => T2, T2 => T1))
4051          then
4052             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
4053          end if;
4054
4055       elsif Op_Name = Name_Op_Expon then
4056          if Is_Numeric_Type (T1)
4057            and then not Is_Fixed_Point_Type (T1)
4058            and then (Base_Type (T2) = Base_Type (Standard_Integer)
4059                       or else T2 = Universal_Integer)
4060          then
4061             Add_One_Interp (N, Op_Id, Base_Type (T1));
4062          end if;
4063
4064       else pragma Assert (Nkind (N) in N_Op_Shift);
4065
4066          --  If not one of the predefined operators, the node may be one
4067          --  of the intrinsic functions. Its kind is always specific, and
4068          --  we can use it directly, rather than the name of the operation.
4069
4070          if Is_Integer_Type (T1)
4071            and then (Base_Type (T2) = Base_Type (Standard_Integer)
4072                       or else T2 = Universal_Integer)
4073          then
4074             Add_One_Interp (N, Op_Id, Base_Type (T1));
4075          end if;
4076       end if;
4077    end Check_Arithmetic_Pair;
4078
4079    -------------------------------
4080    -- Check_Misspelled_Selector --
4081    -------------------------------
4082
4083    procedure Check_Misspelled_Selector
4084      (Prefix : Entity_Id;
4085       Sel    : Node_Id)
4086    is
4087       Max_Suggestions   : constant := 2;
4088       Nr_Of_Suggestions : Natural := 0;
4089
4090       Suggestion_1 : Entity_Id := Empty;
4091       Suggestion_2 : Entity_Id := Empty;
4092
4093       Comp : Entity_Id;
4094
4095    begin
4096       --  All the components of the prefix of selector Sel are matched
4097       --  against  Sel and a count is maintained of possible misspellings.
4098       --  When at the end of the analysis there are one or two (not more!)
4099       --  possible misspellings, these misspellings will be suggested as
4100       --  possible correction.
4101
4102       if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
4103
4104          --  Concurrent types should be handled as well ???
4105
4106          return;
4107       end if;
4108
4109       Comp  := First_Entity (Prefix);
4110       while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
4111          if Is_Visible_Component (Comp) then
4112             if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
4113                Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
4114
4115                case Nr_Of_Suggestions is
4116                   when 1      => Suggestion_1 := Comp;
4117                   when 2      => Suggestion_2 := Comp;
4118                   when others => exit;
4119                end case;
4120             end if;
4121          end if;
4122
4123          Comp := Next_Entity (Comp);
4124       end loop;
4125
4126       --  Report at most two suggestions
4127
4128       if Nr_Of_Suggestions = 1 then
4129          Error_Msg_NE
4130            ("\possible misspelling of&", Sel, Suggestion_1);
4131
4132       elsif Nr_Of_Suggestions = 2 then
4133          Error_Msg_Node_2 := Suggestion_2;
4134          Error_Msg_NE
4135            ("\possible misspelling of& or&", Sel, Suggestion_1);
4136       end if;
4137    end Check_Misspelled_Selector;
4138
4139    ----------------------
4140    -- Defined_In_Scope --
4141    ----------------------
4142
4143    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
4144    is
4145       S1 : constant Entity_Id := Scope (Base_Type (T));
4146    begin
4147       return S1 = S
4148         or else (S1 = System_Aux_Id and then S = Scope (S1));
4149    end Defined_In_Scope;
4150
4151    -------------------
4152    -- Diagnose_Call --
4153    -------------------
4154
4155    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
4156       Actual           : Node_Id;
4157       X                : Interp_Index;
4158       It               : Interp;
4159       Err_Mode         : Boolean;
4160       New_Nam          : Node_Id;
4161       Void_Interp_Seen : Boolean := False;
4162
4163       Success : Boolean;
4164       pragma Warnings (Off, Boolean);
4165
4166    begin
4167       if Ada_Version >= Ada_05 then
4168          Actual := First_Actual (N);
4169          while Present (Actual) loop
4170
4171             --  Ada 2005 (AI-50217): Post an error in case of premature
4172             --  usage of an entity from the limited view.
4173
4174             if not Analyzed (Etype (Actual))
4175              and then From_With_Type (Etype (Actual))
4176             then
4177                Error_Msg_Qual_Level := 1;
4178                Error_Msg_NE
4179                 ("missing with_clause for scope of imported type&",
4180                   Actual, Etype (Actual));
4181                Error_Msg_Qual_Level := 0;
4182             end if;
4183
4184             Next_Actual (Actual);
4185          end loop;
4186       end if;
4187
4188       --   Analyze each candidate call again, with full error reporting
4189       --   for each.
4190
4191       Error_Msg_N
4192         ("no candidate interpretations match the actuals:!", Nam);
4193       Err_Mode := All_Errors_Mode;
4194       All_Errors_Mode := True;
4195
4196       --  If this is a call to an operation of a concurrent type,
4197       --  the failed interpretations have been removed from the
4198       --  name. Recover them to provide full diagnostics.
4199
4200       if Nkind (Parent (Nam)) = N_Selected_Component then
4201          Set_Entity (Nam, Empty);
4202          New_Nam := New_Copy_Tree (Parent (Nam));
4203          Set_Is_Overloaded (New_Nam, False);
4204          Set_Is_Overloaded (Selector_Name (New_Nam), False);
4205          Set_Parent (New_Nam, Parent (Parent (Nam)));
4206          Analyze_Selected_Component (New_Nam);
4207          Get_First_Interp (Selector_Name (New_Nam), X, It);
4208       else
4209          Get_First_Interp (Nam, X, It);
4210       end if;
4211
4212       while Present (It.Nam) loop
4213          if Etype (It.Nam) = Standard_Void_Type then
4214             Void_Interp_Seen := True;
4215          end if;
4216
4217          Analyze_One_Call (N, It.Nam, True, Success);
4218          Get_Next_Interp (X, It);
4219       end loop;
4220
4221       if Nkind (N) = N_Function_Call then
4222          Get_First_Interp (Nam, X, It);
4223          while Present (It.Nam) loop
4224             if Ekind (It.Nam) = E_Function
4225               or else Ekind (It.Nam) = E_Operator
4226             then
4227                return;
4228             else
4229                Get_Next_Interp (X, It);
4230             end if;
4231          end loop;
4232
4233          --  If all interpretations are procedures, this deserves a
4234          --  more precise message. Ditto if this appears as the prefix
4235          --  of a selected component, which may be a lexical error.
4236
4237          Error_Msg_N
4238            ("\context requires function call, found procedure name", Nam);
4239
4240          if Nkind (Parent (N)) = N_Selected_Component
4241            and then N = Prefix (Parent (N))
4242          then
4243             Error_Msg_N (
4244               "\period should probably be semicolon", Parent (N));
4245          end if;
4246
4247       elsif Nkind (N) = N_Procedure_Call_Statement
4248         and then not Void_Interp_Seen
4249       then
4250          Error_Msg_N (
4251          "\function name found in procedure call", Nam);
4252       end if;
4253
4254       All_Errors_Mode := Err_Mode;
4255    end Diagnose_Call;
4256
4257    ---------------------------
4258    -- Find_Arithmetic_Types --
4259    ---------------------------
4260
4261    procedure Find_Arithmetic_Types
4262      (L, R  : Node_Id;
4263       Op_Id : Entity_Id;
4264       N     : Node_Id)
4265    is
4266       Index1 : Interp_Index;
4267       Index2 : Interp_Index;
4268       It1    : Interp;
4269       It2    : Interp;
4270
4271       procedure Check_Right_Argument (T : Entity_Id);
4272       --  Check right operand of operator
4273
4274       --------------------------
4275       -- Check_Right_Argument --
4276       --------------------------
4277
4278       procedure Check_Right_Argument (T : Entity_Id) is
4279       begin
4280          if not Is_Overloaded (R) then
4281             Check_Arithmetic_Pair (T, Etype (R), Op_Id,  N);
4282          else
4283             Get_First_Interp (R, Index2, It2);
4284             while Present (It2.Typ) loop
4285                Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
4286                Get_Next_Interp (Index2, It2);
4287             end loop;
4288          end if;
4289       end Check_Right_Argument;
4290
4291    --  Start processing for Find_Arithmetic_Types
4292
4293    begin
4294       if not Is_Overloaded (L) then
4295          Check_Right_Argument (Etype (L));
4296
4297       else
4298          Get_First_Interp (L, Index1, It1);
4299          while Present (It1.Typ) loop
4300             Check_Right_Argument (It1.Typ);
4301             Get_Next_Interp (Index1, It1);
4302          end loop;
4303       end if;
4304
4305    end Find_Arithmetic_Types;
4306
4307    ------------------------
4308    -- Find_Boolean_Types --
4309    ------------------------
4310
4311    procedure Find_Boolean_Types
4312      (L, R  : Node_Id;
4313       Op_Id : Entity_Id;
4314       N     : Node_Id)
4315    is
4316       Index : Interp_Index;
4317       It    : Interp;
4318
4319       procedure Check_Numeric_Argument (T : Entity_Id);
4320       --  Special case for logical operations one of whose operands is an
4321       --  integer literal. If both are literal the result is any modular type.
4322
4323       ----------------------------
4324       -- Check_Numeric_Argument --
4325       ----------------------------
4326
4327       procedure Check_Numeric_Argument (T : Entity_Id) is
4328       begin
4329          if T = Universal_Integer then
4330             Add_One_Interp (N, Op_Id, Any_Modular);
4331
4332          elsif Is_Modular_Integer_Type (T) then
4333             Add_One_Interp (N, Op_Id, T);
4334          end if;
4335       end Check_Numeric_Argument;
4336
4337    --  Start of processing for Find_Boolean_Types
4338
4339    begin
4340       if not Is_Overloaded (L) then
4341          if Etype (L) = Universal_Integer
4342            or else Etype (L) = Any_Modular
4343          then
4344             if not Is_Overloaded (R) then
4345                Check_Numeric_Argument (Etype (R));
4346
4347             else
4348                Get_First_Interp (R, Index, It);
4349                while Present (It.Typ) loop
4350                   Check_Numeric_Argument (It.Typ);
4351                   Get_Next_Interp (Index, It);
4352                end loop;
4353             end if;
4354
4355          --  If operands are aggregates, we must assume that they may be
4356          --  boolean arrays, and leave disambiguation for the second pass.
4357          --  If only one is an aggregate, verify that the other one has an
4358          --  interpretation as a boolean array
4359
4360          elsif Nkind (L) = N_Aggregate then
4361             if Nkind (R) = N_Aggregate then
4362                Add_One_Interp (N, Op_Id, Etype (L));
4363
4364             elsif not Is_Overloaded (R) then
4365                if Valid_Boolean_Arg (Etype (R)) then
4366                   Add_One_Interp (N, Op_Id, Etype (R));
4367                end if;
4368
4369             else
4370                Get_First_Interp (R, Index, It);
4371                while Present (It.Typ) loop
4372                   if Valid_Boolean_Arg (It.Typ) then
4373                      Add_One_Interp (N, Op_Id, It.Typ);
4374                   end if;
4375
4376                   Get_Next_Interp (Index, It);
4377                end loop;
4378             end if;
4379
4380          elsif Valid_Boolean_Arg (Etype (L))
4381            and then Has_Compatible_Type (R, Etype (L))
4382          then
4383             Add_One_Interp (N, Op_Id, Etype (L));
4384          end if;
4385
4386       else
4387          Get_First_Interp (L, Index, It);
4388          while Present (It.Typ) loop
4389             if Valid_Boolean_Arg (It.Typ)
4390               and then Has_Compatible_Type (R, It.Typ)
4391             then
4392                Add_One_Interp (N, Op_Id, It.Typ);
4393             end if;
4394
4395             Get_Next_Interp (Index, It);
4396          end loop;
4397       end if;
4398    end Find_Boolean_Types;
4399
4400    ---------------------------
4401    -- Find_Comparison_Types --
4402    ---------------------------
4403
4404    procedure Find_Comparison_Types
4405      (L, R  : Node_Id;
4406       Op_Id : Entity_Id;
4407       N     : Node_Id)
4408    is
4409       Index : Interp_Index;
4410       It    : Interp;
4411       Found : Boolean := False;
4412       I_F   : Interp_Index;
4413       T_F   : Entity_Id;
4414       Scop  : Entity_Id := Empty;
4415
4416       procedure Try_One_Interp (T1 : Entity_Id);
4417       --  Routine to try one proposed interpretation. Note that the context
4418       --  of the operator plays no role in resolving the arguments, so that
4419       --  if there is more than one interpretation of the operands that is
4420       --  compatible with comparison, the operation is ambiguous.
4421
4422       --------------------
4423       -- Try_One_Interp --
4424       --------------------
4425
4426       procedure Try_One_Interp (T1 : Entity_Id) is
4427       begin
4428
4429          --  If the operator is an expanded name, then the type of the operand
4430          --  must be defined in the corresponding scope. If the type is
4431          --  universal, the context will impose the correct type.
4432
4433          if Present (Scop)
4434             and then not Defined_In_Scope (T1, Scop)
4435             and then T1 /= Universal_Integer
4436             and then T1 /= Universal_Real
4437             and then T1 /= Any_String
4438             and then T1 /= Any_Composite
4439          then
4440             return;
4441          end if;
4442
4443          if Valid_Comparison_Arg (T1)
4444            and then Has_Compatible_Type (R, T1)
4445          then
4446             if Found
4447               and then Base_Type (T1) /= Base_Type (T_F)
4448             then
4449                It := Disambiguate (L, I_F, Index, Any_Type);
4450
4451                if It = No_Interp then
4452                   Ambiguous_Operands (N);
4453                   Set_Etype (L, Any_Type);
4454                   return;
4455
4456                else
4457                   T_F := It.Typ;
4458                end if;
4459
4460             else
4461                Found := True;
4462                T_F   := T1;
4463                I_F   := Index;
4464             end if;
4465
4466             Set_Etype (L, T_F);
4467             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4468
4469          end if;
4470       end Try_One_Interp;
4471
4472    --  Start processing for Find_Comparison_Types
4473
4474    begin
4475       --  If left operand is aggregate, the right operand has to
4476       --  provide a usable type for it.
4477
4478       if Nkind (L) = N_Aggregate
4479         and then Nkind (R) /= N_Aggregate
4480       then
4481          Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
4482          return;
4483       end if;
4484
4485       if Nkind (N) = N_Function_Call
4486          and then Nkind (Name (N)) = N_Expanded_Name
4487       then
4488          Scop := Entity (Prefix (Name (N)));
4489
4490          --  The prefix may be a package renaming, and the subsequent test
4491          --  requires the original package.
4492
4493          if Ekind (Scop) = E_Package
4494            and then Present (Renamed_Entity (Scop))
4495          then
4496             Scop := Renamed_Entity (Scop);
4497             Set_Entity (Prefix (Name (N)), Scop);
4498          end if;
4499       end if;
4500
4501       if not Is_Overloaded (L) then
4502          Try_One_Interp (Etype (L));
4503
4504       else
4505          Get_First_Interp (L, Index, It);
4506          while Present (It.Typ) loop
4507             Try_One_Interp (It.Typ);
4508             Get_Next_Interp (Index, It);
4509          end loop;
4510       end if;
4511    end Find_Comparison_Types;
4512
4513    ----------------------------------------
4514    -- Find_Non_Universal_Interpretations --
4515    ----------------------------------------
4516
4517    procedure Find_Non_Universal_Interpretations
4518      (N     : Node_Id;
4519       R     : Node_Id;
4520       Op_Id : Entity_Id;
4521       T1    : Entity_Id)
4522    is
4523       Index : Interp_Index;
4524       It    : Interp;
4525
4526    begin
4527       if T1 = Universal_Integer
4528         or else T1 = Universal_Real
4529       then
4530          if not Is_Overloaded (R) then
4531             Add_One_Interp
4532               (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
4533          else
4534             Get_First_Interp (R, Index, It);
4535             while Present (It.Typ) loop
4536                if Covers (It.Typ, T1) then
4537                   Add_One_Interp
4538                     (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
4539                end if;
4540
4541                Get_Next_Interp (Index, It);
4542             end loop;
4543          end if;
4544       else
4545          Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
4546       end if;
4547    end Find_Non_Universal_Interpretations;
4548
4549    ------------------------------
4550    -- Find_Concatenation_Types --
4551    ------------------------------
4552
4553    procedure Find_Concatenation_Types
4554      (L, R  : Node_Id;
4555       Op_Id : Entity_Id;
4556       N     : Node_Id)
4557    is
4558       Op_Type : constant Entity_Id := Etype (Op_Id);
4559
4560    begin
4561       if Is_Array_Type (Op_Type)
4562         and then not Is_Limited_Type (Op_Type)
4563
4564         and then (Has_Compatible_Type (L, Op_Type)
4565                     or else
4566                   Has_Compatible_Type (L, Component_Type (Op_Type)))
4567
4568         and then (Has_Compatible_Type (R, Op_Type)
4569                     or else
4570                   Has_Compatible_Type (R, Component_Type (Op_Type)))
4571       then
4572          Add_One_Interp (N, Op_Id, Op_Type);
4573       end if;
4574    end Find_Concatenation_Types;
4575
4576    -------------------------
4577    -- Find_Equality_Types --
4578    -------------------------
4579
4580    procedure Find_Equality_Types
4581      (L, R  : Node_Id;
4582       Op_Id : Entity_Id;
4583       N     : Node_Id)
4584    is
4585       Index : Interp_Index;
4586       It    : Interp;
4587       Found : Boolean := False;
4588       I_F   : Interp_Index;
4589       T_F   : Entity_Id;
4590       Scop  : Entity_Id := Empty;
4591
4592       procedure Try_One_Interp (T1 : Entity_Id);
4593       --  The context of the operator plays no role in resolving the
4594       --  arguments,  so that if there is more than one interpretation
4595       --  of the operands that is compatible with equality, the construct
4596       --  is ambiguous and an error can be emitted now, after trying to
4597       --  disambiguate, i.e. applying preference rules.
4598
4599       --------------------
4600       -- Try_One_Interp --
4601       --------------------
4602
4603       procedure Try_One_Interp (T1 : Entity_Id) is
4604       begin
4605          --  If the operator is an expanded name, then the type of the operand
4606          --  must be defined in the corresponding scope. If the type is
4607          --  universal, the context will impose the correct type. An anonymous
4608          --  type for a 'Access reference is also universal in this sense, as
4609          --  the actual type is obtained from context.
4610          --  In Ada 2005, the equality operator for anonymous access types
4611          --  is declared in Standard, and preference rules apply to it.
4612
4613          if Present (Scop) then
4614             if Defined_In_Scope (T1, Scop)
4615               or else T1 = Universal_Integer
4616               or else T1 = Universal_Real
4617               or else T1 = Any_Access
4618               or else T1 = Any_String
4619               or else T1 = Any_Composite
4620               or else (Ekind (T1) = E_Access_Subprogram_Type
4621                           and then not Comes_From_Source (T1))
4622             then
4623                null;
4624
4625             elsif Ekind (T1) = E_Anonymous_Access_Type
4626               and then Scop = Standard_Standard
4627             then
4628                null;
4629
4630             else
4631                --  The scope does not contain an operator for the type
4632
4633                return;
4634             end if;
4635          end if;
4636
4637          --  Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
4638          --  Do not allow anonymous access types in equality operators.
4639
4640          if Ada_Version < Ada_05
4641            and then Ekind (T1) = E_Anonymous_Access_Type
4642          then
4643             return;
4644          end if;
4645
4646          if T1 /= Standard_Void_Type
4647            and then not Is_Limited_Type (T1)
4648            and then not Is_Limited_Composite (T1)
4649            and then Has_Compatible_Type (R, T1)
4650          then
4651             if Found
4652               and then Base_Type (T1) /= Base_Type (T_F)
4653             then
4654                It := Disambiguate (L, I_F, Index, Any_Type);
4655
4656                if It = No_Interp then
4657                   Ambiguous_Operands (N);
4658                   Set_Etype (L, Any_Type);
4659                   return;
4660
4661                else
4662                   T_F := It.Typ;
4663                end if;
4664
4665             else
4666                Found := True;
4667                T_F   := T1;
4668                I_F   := Index;
4669             end if;
4670
4671             if not Analyzed (L) then
4672                Set_Etype (L, T_F);
4673             end if;
4674
4675             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4676
4677             --  Case of operator was not visible, Etype still set to Any_Type
4678
4679             if Etype (N) = Any_Type then
4680                Found := False;
4681             end if;
4682
4683          elsif Scop = Standard_Standard
4684            and then Ekind (T1) = E_Anonymous_Access_Type
4685          then
4686             Found := True;
4687          end if;
4688       end Try_One_Interp;
4689
4690    --  Start of processing for Find_Equality_Types
4691
4692    begin
4693       --  If left operand is aggregate, the right operand has to
4694       --  provide a usable type for it.
4695
4696       if Nkind (L) = N_Aggregate
4697         and then Nkind (R) /= N_Aggregate
4698       then
4699          Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
4700          return;
4701       end if;
4702
4703       if Nkind (N) = N_Function_Call
4704          and then Nkind (Name (N)) = N_Expanded_Name
4705       then
4706          Scop := Entity (Prefix (Name (N)));
4707
4708          --  The prefix may be a package renaming, and the subsequent test
4709          --  requires the original package.
4710
4711          if Ekind (Scop) = E_Package
4712            and then Present (Renamed_Entity (Scop))
4713          then
4714             Scop := Renamed_Entity (Scop);
4715             Set_Entity (Prefix (Name (N)), Scop);
4716          end if;
4717       end if;
4718
4719       if not Is_Overloaded (L) then
4720          Try_One_Interp (Etype (L));
4721
4722       else
4723          Get_First_Interp (L, Index, It);
4724          while Present (It.Typ) loop
4725             Try_One_Interp (It.Typ);
4726             Get_Next_Interp (Index, It);
4727          end loop;
4728       end if;
4729    end Find_Equality_Types;
4730
4731    -------------------------
4732    -- Find_Negation_Types --
4733    -------------------------
4734
4735    procedure Find_Negation_Types
4736      (R     : Node_Id;
4737       Op_Id : Entity_Id;
4738       N     : Node_Id)
4739    is
4740       Index : Interp_Index;
4741       It    : Interp;
4742
4743    begin
4744       if not Is_Overloaded (R) then
4745          if Etype (R) = Universal_Integer then
4746             Add_One_Interp (N, Op_Id, Any_Modular);
4747          elsif Valid_Boolean_Arg (Etype (R)) then
4748             Add_One_Interp (N, Op_Id, Etype (R));
4749          end if;
4750
4751       else
4752          Get_First_Interp (R, Index, It);
4753          while Present (It.Typ) loop
4754             if Valid_Boolean_Arg (It.Typ) then
4755                Add_One_Interp (N, Op_Id, It.Typ);
4756             end if;
4757
4758             Get_Next_Interp (Index, It);
4759          end loop;
4760       end if;
4761    end Find_Negation_Types;
4762
4763    ------------------------------
4764    -- Find_Primitive_Operation --
4765    ------------------------------
4766
4767    function Find_Primitive_Operation (N : Node_Id) return Boolean is
4768       Obj : constant Node_Id := Prefix (N);
4769       Op  : constant Node_Id := Selector_Name (N);
4770
4771       Prim  : Elmt_Id;
4772       Prims : Elist_Id;
4773       Typ   : Entity_Id;
4774
4775    begin
4776       Set_Etype (Op, Any_Type);
4777
4778       if Is_Access_Type (Etype (Obj)) then
4779          Typ := Designated_Type (Etype (Obj));
4780       else
4781          Typ := Etype (Obj);
4782       end if;
4783
4784       if Is_Class_Wide_Type (Typ) then
4785          Typ := Root_Type (Typ);
4786       end if;
4787
4788       Prims := Primitive_Operations (Typ);
4789
4790       Prim := First_Elmt (Prims);
4791       while Present (Prim) loop
4792          if Chars (Node (Prim)) = Chars (Op) then
4793             Add_One_Interp (Op, Node (Prim), Etype (Node (Prim)));
4794             Set_Etype (N, Etype (Node (Prim)));
4795          end if;
4796
4797          Next_Elmt (Prim);
4798       end loop;
4799
4800       --  Now look for class-wide operations of the type or any of its
4801       --  ancestors by iterating over the homonyms of the selector.
4802
4803       declare
4804          Cls_Type : constant Entity_Id := Class_Wide_Type (Typ);
4805          Hom      : Entity_Id;
4806
4807       begin
4808          Hom := Current_Entity (Op);
4809          while Present (Hom) loop
4810             if (Ekind (Hom) = E_Procedure
4811                   or else
4812                 Ekind (Hom) = E_Function)
4813               and then Scope (Hom) = Scope (Typ)
4814               and then Present (First_Formal (Hom))
4815               and then
4816                 (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
4817                   or else
4818                     (Is_Access_Type (Etype (First_Formal (Hom)))
4819                        and then
4820                          Ekind (Etype (First_Formal (Hom))) =
4821                            E_Anonymous_Access_Type
4822                        and then
4823                          Base_Type
4824                            (Designated_Type (Etype (First_Formal (Hom)))) =
4825                                                                 Cls_Type))
4826             then
4827                Add_One_Interp (Op, Hom, Etype (Hom));
4828                Set_Etype (N, Etype (Hom));
4829             end if;
4830
4831             Hom := Homonym (Hom);
4832          end loop;
4833       end;
4834
4835       return Etype (Op) /= Any_Type;
4836    end Find_Primitive_Operation;
4837
4838    ----------------------
4839    -- Find_Unary_Types --
4840    ----------------------
4841
4842    procedure Find_Unary_Types
4843      (R     : Node_Id;
4844       Op_Id : Entity_Id;
4845       N     : Node_Id)
4846    is
4847       Index : Interp_Index;
4848       It    : Interp;
4849
4850    begin
4851       if not Is_Overloaded (R) then
4852          if Is_Numeric_Type (Etype (R)) then
4853             Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
4854          end if;
4855
4856       else
4857          Get_First_Interp (R, Index, It);
4858          while Present (It.Typ) loop
4859             if Is_Numeric_Type (It.Typ) then
4860                Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
4861             end if;
4862
4863             Get_Next_Interp (Index, It);
4864          end loop;
4865       end if;
4866    end Find_Unary_Types;
4867
4868    ------------------
4869    -- Junk_Operand --
4870    ------------------
4871
4872    function Junk_Operand (N : Node_Id) return Boolean is
4873       Enode : Node_Id;
4874
4875    begin
4876       if Error_Posted (N) then
4877          return False;
4878       end if;
4879
4880       --  Get entity to be tested
4881
4882       if Is_Entity_Name (N)
4883         and then Present (Entity (N))
4884       then
4885          Enode := N;
4886
4887       --  An odd case, a procedure name gets converted to a very peculiar
4888       --  function call, and here is where we detect this happening.
4889
4890       elsif Nkind (N) = N_Function_Call
4891         and then Is_Entity_Name (Name (N))
4892         and then Present (Entity (Name (N)))
4893       then
4894          Enode := Name (N);
4895
4896       --  Another odd case, there are at least some cases of selected
4897       --  components where the selected component is not marked as having
4898       --  an entity, even though the selector does have an entity
4899
4900       elsif Nkind (N) = N_Selected_Component
4901         and then Present (Entity (Selector_Name (N)))
4902       then
4903          Enode := Selector_Name (N);
4904
4905       else
4906          return False;
4907       end if;
4908
4909       --  Now test the entity we got to see if it is a bad case
4910
4911       case Ekind (Entity (Enode)) is
4912
4913          when E_Package =>
4914             Error_Msg_N
4915               ("package name cannot be used as operand", Enode);
4916
4917          when Generic_Unit_Kind =>
4918             Error_Msg_N
4919               ("generic unit name cannot be used as operand", Enode);
4920
4921          when Type_Kind =>
4922             Error_Msg_N
4923               ("subtype name cannot be used as operand", Enode);
4924
4925          when Entry_Kind =>
4926             Error_Msg_N
4927               ("entry name cannot be used as operand", Enode);
4928
4929          when E_Procedure =>
4930             Error_Msg_N
4931               ("procedure name cannot be used as operand", Enode);
4932
4933          when E_Exception =>
4934             Error_Msg_N
4935               ("exception name cannot be used as operand", Enode);
4936
4937          when E_Block | E_Label | E_Loop =>
4938             Error_Msg_N
4939               ("label name cannot be used as operand", Enode);
4940
4941          when others =>
4942             return False;
4943
4944       end case;
4945
4946       return True;
4947    end Junk_Operand;
4948
4949    --------------------
4950    -- Operator_Check --
4951    --------------------
4952
4953    procedure Operator_Check (N : Node_Id) is
4954    begin
4955       Remove_Abstract_Operations (N);
4956
4957       --  Test for case of no interpretation found for operator
4958
4959       if Etype (N) = Any_Type then
4960          declare
4961             L     : Node_Id;
4962             R     : Node_Id;
4963             Op_Id : Entity_Id := Empty;
4964
4965          begin
4966             R := Right_Opnd (N);
4967
4968             if Nkind (N) in N_Binary_Op then
4969                L := Left_Opnd (N);
4970             else
4971                L := Empty;
4972             end if;
4973
4974             --  If either operand has no type, then don't complain further,
4975             --  since this simply means that we have a propagated error.
4976
4977             if R = Error
4978               or else Etype (R) = Any_Type
4979               or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
4980             then
4981                return;
4982
4983             --  We explicitly check for the case of concatenation of component
4984             --  with component to avoid reporting spurious matching array types
4985             --  that might happen to be lurking in distant packages (such as
4986             --  run-time packages). This also prevents inconsistencies in the
4987             --  messages for certain ACVC B tests, which can vary depending on
4988             --  types declared in run-time interfaces. Another improvement when
4989             --  aggregates are present is to look for a well-typed operand.
4990
4991             elsif Present (Candidate_Type)
4992               and then (Nkind (N) /= N_Op_Concat
4993                          or else Is_Array_Type (Etype (L))
4994                          or else Is_Array_Type (Etype (R)))
4995             then
4996
4997                if Nkind (N) = N_Op_Concat then
4998                   if Etype (L) /= Any_Composite
4999                     and then Is_Array_Type (Etype (L))
5000                   then
5001                      Candidate_Type := Etype (L);
5002
5003                   elsif Etype (R) /= Any_Composite
5004                     and then Is_Array_Type (Etype (R))
5005                   then
5006                      Candidate_Type := Etype (R);
5007                   end if;
5008                end if;
5009
5010                Error_Msg_NE
5011                  ("operator for} is not directly visible!",
5012                   N, First_Subtype (Candidate_Type));
5013                Error_Msg_N ("use clause would make operation legal!",  N);
5014                return;
5015
5016             --  If either operand is a junk operand (e.g. package name), then
5017             --  post appropriate error messages, but do not complain further.
5018
5019             --  Note that the use of OR in this test instead of OR ELSE is
5020             --  quite deliberate, we may as well check both operands in the
5021             --  binary operator case.
5022
5023             elsif Junk_Operand (R)
5024               or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
5025             then
5026                return;
5027
5028             --  If we have a logical operator, one of whose operands is
5029             --  Boolean, then we know that the other operand cannot resolve to
5030             --  Boolean (since we got no interpretations), but in that case we
5031             --  pretty much know that the other operand should be Boolean, so
5032             --  resolve it that way (generating an error)
5033
5034             elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then
5035                if Etype (L) = Standard_Boolean then
5036                   Resolve (R, Standard_Boolean);
5037                   return;
5038                elsif Etype (R) = Standard_Boolean then
5039                   Resolve (L, Standard_Boolean);
5040                   return;
5041                end if;
5042
5043             --  For an arithmetic operator or comparison operator, if one
5044             --  of the operands is numeric, then we know the other operand
5045             --  is not the same numeric type. If it is a non-numeric type,
5046             --  then probably it is intended to match the other operand.
5047
5048             elsif Nkind_In (N, N_Op_Add,
5049                                N_Op_Divide,
5050                                N_Op_Ge,
5051                                N_Op_Gt,
5052                                N_Op_Le)
5053               or else
5054                   Nkind_In (N, N_Op_Lt,
5055                                N_Op_Mod,
5056                                N_Op_Multiply,
5057                                N_Op_Rem,
5058                                N_Op_Subtract)
5059             then
5060                if Is_Numeric_Type (Etype (L))
5061                  and then not Is_Numeric_Type (Etype (R))
5062                then
5063                   Resolve (R, Etype (L));
5064                   return;
5065
5066                elsif Is_Numeric_Type (Etype (R))
5067                  and then not Is_Numeric_Type (Etype (L))
5068                then
5069                   Resolve (L, Etype (R));
5070                   return;
5071                end if;
5072
5073             --  Comparisons on A'Access are common enough to deserve a
5074             --  special message.
5075
5076             elsif Nkind_In (N, N_Op_Eq, N_Op_Ne)
5077                and then Ekind (Etype (L)) = E_Access_Attribute_Type
5078                and then Ekind (Etype (R)) = E_Access_Attribute_Type
5079             then
5080                Error_Msg_N
5081                  ("two access attributes cannot be compared directly", N);
5082                Error_Msg_N
5083                  ("\use qualified expression for one of the operands",
5084                    N);
5085                return;
5086
5087             --  Another one for C programmers
5088
5089             elsif Nkind (N) = N_Op_Concat
5090               and then Valid_Boolean_Arg (Etype (L))
5091               and then Valid_Boolean_Arg (Etype (R))
5092             then
5093                Error_Msg_N ("invalid operands for concatenation", N);
5094                Error_Msg_N ("\maybe AND was meant", N);
5095                return;
5096
5097             --  A special case for comparison of access parameter with null
5098
5099             elsif Nkind (N) = N_Op_Eq
5100               and then Is_Entity_Name (L)
5101               and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
5102               and then Nkind (Parameter_Type (Parent (Entity (L)))) =
5103                                                   N_Access_Definition
5104               and then Nkind (R) = N_Null
5105             then
5106                Error_Msg_N ("access parameter is not allowed to be null", L);
5107                Error_Msg_N ("\(call would raise Constraint_Error)", L);
5108                return;
5109             end if;
5110
5111             --  If we fall through then just give general message. Note that in
5112             --  the following messages, if the operand is overloaded we choose
5113             --  an arbitrary type to complain about, but that is probably more
5114             --  useful than not giving a type at all.
5115
5116             if Nkind (N) in N_Unary_Op then
5117                Error_Msg_Node_2 := Etype (R);
5118                Error_Msg_N ("operator& not defined for}", N);
5119                return;
5120
5121             else
5122                if Nkind (N) in N_Binary_Op then
5123                   if not Is_Overloaded (L)
5124                     and then not Is_Overloaded (R)
5125                     and then Base_Type (Etype (L)) = Base_Type (Etype (R))
5126                   then
5127                      Error_Msg_Node_2 := First_Subtype (Etype (R));
5128                      Error_Msg_N ("there is no applicable operator& for}", N);
5129
5130                   else
5131                      --  Another attempt to find a fix: one of the candidate
5132                      --  interpretations may not be use-visible. This has
5133                      --  already been checked for predefined operators, so
5134                      --  we examine only user-defined functions.
5135
5136                      Op_Id := Get_Name_Entity_Id (Chars (N));
5137
5138                      while Present (Op_Id) loop
5139                         if Ekind (Op_Id) /= E_Operator
5140                           and then Is_Overloadable (Op_Id)
5141                         then
5142                            if not Is_Immediately_Visible (Op_Id)
5143                              and then not In_Use (Scope (Op_Id))
5144                              and then not Is_Abstract_Subprogram (Op_Id)
5145                              and then not Is_Hidden (Op_Id)
5146                              and then Ekind (Scope (Op_Id)) = E_Package
5147                              and then
5148                                Has_Compatible_Type
5149                                  (L, Etype (First_Formal (Op_Id)))
5150                              and then Present
5151                               (Next_Formal (First_Formal (Op_Id)))
5152                              and then
5153                                Has_Compatible_Type
5154                                  (R,
5155                                   Etype (Next_Formal (First_Formal (Op_Id))))
5156                            then
5157                               Error_Msg_N
5158                                 ("No legal interpretation for operator&", N);
5159                               Error_Msg_NE
5160                                 ("\use clause on& would make operation legal",
5161                                    N, Scope (Op_Id));
5162                               exit;
5163                            end if;
5164                         end if;
5165
5166                         Op_Id := Homonym (Op_Id);
5167                      end loop;
5168
5169                      if No (Op_Id) then
5170                         Error_Msg_N ("invalid operand types for operator&", N);
5171
5172                         if Nkind (N) /= N_Op_Concat then
5173                            Error_Msg_NE ("\left operand has}!",  N, Etype (L));
5174                            Error_Msg_NE ("\right operand has}!", N, Etype (R));
5175                         end if;
5176                      end if;
5177                   end if;
5178                end if;
5179             end if;
5180          end;
5181       end if;
5182    end Operator_Check;
5183
5184    -----------------------------------------
5185    -- Process_Implicit_Dereference_Prefix --
5186    -----------------------------------------
5187
5188    function Process_Implicit_Dereference_Prefix
5189      (E : Entity_Id;
5190       P : Entity_Id) return Entity_Id
5191    is
5192       Ref : Node_Id;
5193       Typ : constant Entity_Id := Designated_Type (Etype (P));
5194
5195    begin
5196       if Present (E)
5197         and then (Operating_Mode = Check_Semantics or else not Expander_Active)
5198       then
5199          --  We create a dummy reference to E to ensure that the reference
5200          --  is not considered as part of an assignment (an implicit
5201          --  dereference can never assign to its prefix). The Comes_From_Source
5202          --  attribute needs to be propagated for accurate warnings.
5203
5204          Ref := New_Reference_To (E, Sloc (P));
5205          Set_Comes_From_Source (Ref, Comes_From_Source (P));
5206          Generate_Reference (E, Ref);
5207       end if;
5208
5209       --  An implicit dereference is a legal occurrence of an
5210       --  incomplete type imported through a limited_with clause,
5211       --  if the full view is visible.
5212
5213       if From_With_Type (Typ)
5214         and then not From_With_Type (Scope (Typ))
5215         and then
5216           (Is_Immediately_Visible (Scope (Typ))
5217             or else
5218               (Is_Child_Unit (Scope (Typ))
5219                  and then Is_Visible_Child_Unit (Scope (Typ))))
5220       then
5221          return Available_View (Typ);
5222       else
5223          return Typ;
5224       end if;
5225
5226    end Process_Implicit_Dereference_Prefix;
5227
5228    --------------------------------
5229    -- Remove_Abstract_Operations --
5230    --------------------------------
5231
5232    procedure Remove_Abstract_Operations (N : Node_Id) is
5233       Abstract_Op    : Entity_Id := Empty;
5234       Address_Kludge : Boolean := False;
5235       I              : Interp_Index;
5236       It             : Interp;
5237
5238       --  AI-310: If overloaded, remove abstract non-dispatching operations. We
5239       --  activate this if either extensions are enabled, or if the abstract
5240       --  operation in question comes from a predefined file. This latter test
5241       --  allows us to use abstract to make operations invisible to users. In
5242       --  particular, if type Address is non-private and abstract subprograms
5243       --  are used to hide its operators, they will be truly hidden.
5244
5245       type Operand_Position is (First_Op, Second_Op);
5246       Univ_Type : constant Entity_Id := Universal_Interpretation (N);
5247
5248       procedure Remove_Address_Interpretations (Op : Operand_Position);
5249       --  Ambiguities may arise when the operands are literal and the address
5250       --  operations in s-auxdec are visible. In that case, remove the
5251       --  interpretation of a literal as Address, to retain the semantics of
5252       --  Address as a private type.
5253
5254       ------------------------------------
5255       -- Remove_Address_Interpretations --
5256       ------------------------------------
5257
5258       procedure Remove_Address_Interpretations (Op : Operand_Position) is
5259          Formal : Entity_Id;
5260
5261       begin
5262          if Is_Overloaded (N) then
5263             Get_First_Interp (N, I, It);
5264             while Present (It.Nam) loop
5265                Formal := First_Entity (It.Nam);
5266
5267                if Op = Second_Op then
5268                   Formal := Next_Entity (Formal);
5269                end if;
5270
5271                if Is_Descendent_Of_Address (Etype (Formal)) then
5272                   Address_Kludge := True;
5273                   Remove_Interp (I);
5274                end if;
5275
5276                Get_Next_Interp (I, It);
5277             end loop;
5278          end if;
5279       end Remove_Address_Interpretations;
5280
5281    --  Start of processing for Remove_Abstract_Operations
5282
5283    begin
5284       if Is_Overloaded (N) then
5285          Get_First_Interp (N, I, It);
5286
5287          while Present (It.Nam) loop
5288             if Is_Overloadable (It.Nam)
5289               and then Is_Abstract_Subprogram (It.Nam)
5290               and then not Is_Dispatching_Operation (It.Nam)
5291             then
5292                Abstract_Op := It.Nam;
5293
5294                if Is_Descendent_Of_Address (It.Typ) then
5295                   Address_Kludge := True;
5296                   Remove_Interp (I);
5297                   exit;
5298
5299                --  In Ada 2005, this operation does not participate in Overload
5300                --  resolution. If the operation is defined in a predefined
5301                --  unit, it is one of the operations declared abstract in some
5302                --  variants of System, and it must be removed as well.
5303
5304                elsif Ada_Version >= Ada_05
5305                  or else Is_Predefined_File_Name
5306                            (Unit_File_Name (Get_Source_Unit (It.Nam)))
5307                then
5308                   Remove_Interp (I);
5309                   exit;
5310                end if;
5311             end if;
5312
5313             Get_Next_Interp (I, It);
5314          end loop;
5315
5316          if No (Abstract_Op) then
5317
5318             --  If some interpretation yields an integer type, it is still
5319             --  possible that there are address interpretations. Remove them
5320             --  if one operand is a literal, to avoid spurious ambiguities
5321             --  on systems where Address is a visible integer type.
5322
5323             if Is_Overloaded (N)
5324               and then Nkind (N) in N_Op
5325               and then Is_Integer_Type (Etype (N))
5326             then
5327                if Nkind (N) in N_Binary_Op then
5328                   if Nkind (Right_Opnd (N)) = N_Integer_Literal then
5329                      Remove_Address_Interpretations (Second_Op);
5330
5331                   elsif Nkind (Right_Opnd (N)) = N_Integer_Literal then
5332                      Remove_Address_Interpretations (First_Op);
5333                   end if;
5334                end if;
5335             end if;
5336
5337          elsif Nkind (N) in N_Op then
5338
5339             --  Remove interpretations that treat literals as addresses. This
5340             --  is never appropriate, even when Address is defined as a visible
5341             --  Integer type. The reason is that we would really prefer Address
5342             --  to behave as a private type, even in this case, which is there
5343             --  only to accomodate oddities of VMS address sizes. If Address is
5344             --  a visible integer type, we get lots of overload ambiguities.
5345
5346             if Nkind (N) in N_Binary_Op then
5347                declare
5348                   U1 : constant Boolean :=
5349                      Present (Universal_Interpretation (Right_Opnd (N)));
5350                   U2 : constant Boolean :=
5351                      Present (Universal_Interpretation (Left_Opnd (N)));
5352
5353                begin
5354                   if U1 then
5355                      Remove_Address_Interpretations (Second_Op);
5356                   end if;
5357
5358                   if U2 then
5359                      Remove_Address_Interpretations (First_Op);
5360                   end if;
5361
5362                   if not (U1 and U2) then
5363
5364                      --  Remove corresponding predefined operator, which is
5365                      --  always added to the overload set.
5366
5367                      Get_First_Interp (N, I, It);
5368                      while Present (It.Nam) loop
5369                         if Scope (It.Nam) = Standard_Standard
5370                           and then Base_Type (It.Typ) =
5371                                    Base_Type (Etype (Abstract_Op))
5372                         then
5373                            Remove_Interp (I);
5374                         end if;
5375
5376                         Get_Next_Interp (I, It);
5377                      end loop;
5378
5379                   elsif Is_Overloaded (N)
5380                     and then Present (Univ_Type)
5381                   then
5382                      --  If both operands have a universal interpretation,
5383                      --  it is still necessary to remove interpretations that
5384                      --  yield Address. Any remaining ambiguities will be
5385                      --  removed in Disambiguate.
5386
5387                      Get_First_Interp (N, I, It);
5388                      while Present (It.Nam) loop
5389                         if Is_Descendent_Of_Address (It.Typ) then
5390                            Remove_Interp (I);
5391
5392                         elsif not Is_Type (It.Nam) then
5393                            Set_Entity (N, It.Nam);
5394                         end if;
5395
5396                         Get_Next_Interp (I, It);
5397                      end loop;
5398                   end if;
5399                end;
5400             end if;
5401
5402          elsif Nkind (N) = N_Function_Call
5403            and then
5404              (Nkind (Name (N)) = N_Operator_Symbol
5405                 or else
5406                   (Nkind (Name (N)) = N_Expanded_Name
5407                      and then
5408                        Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
5409          then
5410
5411             declare
5412                Arg1 : constant Node_Id := First (Parameter_Associations (N));
5413                U1   : constant Boolean :=
5414                         Present (Universal_Interpretation (Arg1));
5415                U2   : constant Boolean :=
5416                         Present (Next (Arg1)) and then
5417                         Present (Universal_Interpretation (Next (Arg1)));
5418
5419             begin
5420                if U1 then
5421                   Remove_Address_Interpretations (First_Op);
5422                end if;
5423
5424                if U2 then
5425                   Remove_Address_Interpretations (Second_Op);
5426                end if;
5427
5428                if not (U1 and U2) then
5429                   Get_First_Interp (N, I, It);
5430                   while Present (It.Nam) loop
5431                      if Scope (It.Nam) = Standard_Standard
5432                        and then It.Typ = Base_Type (Etype (Abstract_Op))
5433                      then
5434                         Remove_Interp (I);
5435                      end if;
5436
5437                      Get_Next_Interp (I, It);
5438                   end loop;
5439                end if;
5440             end;
5441          end if;
5442
5443          --  If the removal has left no valid interpretations, emit an error
5444          --  message now and label node as illegal.
5445
5446          if Present (Abstract_Op) then
5447             Get_First_Interp (N, I, It);
5448
5449             if No (It.Nam) then
5450
5451                --  Removal of abstract operation left no viable candidate
5452
5453                Set_Etype (N, Any_Type);
5454                Error_Msg_Sloc := Sloc (Abstract_Op);
5455                Error_Msg_NE
5456                  ("cannot call abstract operation& declared#", N, Abstract_Op);
5457
5458             --  In Ada 2005, an abstract operation may disable predefined
5459             --  operators. Since the context is not yet known, we mark the
5460             --  predefined operators as potentially hidden. Do not include
5461             --  predefined operators when addresses are involved since this
5462             --  case is handled separately.
5463
5464             elsif Ada_Version >= Ada_05
5465               and then not Address_Kludge
5466             then
5467                while Present (It.Nam) loop
5468                   if Is_Numeric_Type (It.Typ)
5469                     and then Scope (It.Typ) = Standard_Standard
5470                   then
5471                      Set_Abstract_Op (I, Abstract_Op);
5472                   end if;
5473
5474                   Get_Next_Interp (I, It);
5475                end loop;
5476             end if;
5477          end if;
5478       end if;
5479    end Remove_Abstract_Operations;
5480
5481    -----------------------
5482    -- Try_Indirect_Call --
5483    -----------------------
5484
5485    function Try_Indirect_Call
5486      (N   : Node_Id;
5487       Nam : Entity_Id;
5488       Typ : Entity_Id) return Boolean
5489    is
5490       Actual : Node_Id;
5491       Formal : Entity_Id;
5492
5493       Call_OK : Boolean;
5494       pragma Warnings (Off, Call_OK);
5495
5496    begin
5497       Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK);
5498
5499       Actual := First_Actual (N);
5500       Formal := First_Formal (Designated_Type (Typ));
5501       while Present (Actual) and then Present (Formal) loop
5502          if not Has_Compatible_Type (Actual, Etype (Formal)) then
5503             return False;
5504          end if;
5505
5506          Next (Actual);
5507          Next_Formal (Formal);
5508       end loop;
5509
5510       if No (Actual) and then No (Formal) then
5511          Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
5512
5513          --  Nam is a candidate interpretation for the name in the call,
5514          --  if it is not an indirect call.
5515
5516          if not Is_Type (Nam)
5517             and then Is_Entity_Name (Name (N))
5518          then
5519             Set_Entity (Name (N), Nam);
5520          end if;
5521
5522          return True;
5523       else
5524          return False;
5525       end if;
5526    end Try_Indirect_Call;
5527
5528    ----------------------
5529    -- Try_Indexed_Call --
5530    ----------------------
5531
5532    function Try_Indexed_Call
5533      (N          : Node_Id;
5534       Nam        : Entity_Id;
5535       Typ        : Entity_Id;
5536       Skip_First : Boolean) return Boolean
5537    is
5538       Actuals : constant List_Id   := Parameter_Associations (N);
5539       Actual : Node_Id;
5540       Index  : Entity_Id;
5541
5542    begin
5543       Actual := First (Actuals);
5544
5545       --  If the call was originally written in prefix form, skip the first
5546       --  actual, which is obviously not defaulted.
5547
5548       if Skip_First then
5549          Next (Actual);
5550       end if;
5551
5552       Index := First_Index (Typ);
5553       while Present (Actual) and then Present (Index) loop
5554
5555          --  If the parameter list has a named association, the expression
5556          --  is definitely a call and not an indexed component.
5557
5558          if Nkind (Actual) = N_Parameter_Association then
5559             return False;
5560          end if;
5561
5562          if not Has_Compatible_Type (Actual, Etype (Index)) then
5563             return False;
5564          end if;
5565
5566          Next (Actual);
5567          Next_Index (Index);
5568       end loop;
5569
5570       if No (Actual) and then No (Index) then
5571          Add_One_Interp (N, Nam, Component_Type (Typ));
5572
5573          --  Nam is a candidate interpretation for the name in the call,
5574          --  if it is not an indirect call.
5575
5576          if not Is_Type (Nam)
5577             and then Is_Entity_Name (Name (N))
5578          then
5579             Set_Entity (Name (N), Nam);
5580          end if;
5581
5582          return True;
5583       else
5584          return False;
5585       end if;
5586    end Try_Indexed_Call;
5587
5588    --------------------------
5589    -- Try_Object_Operation --
5590    --------------------------
5591
5592    function Try_Object_Operation (N : Node_Id) return Boolean is
5593       K              : constant Node_Kind  := Nkind (Parent (N));
5594       Is_Subprg_Call : constant Boolean    := Nkind_In
5595                                                (K, N_Procedure_Call_Statement,
5596                                                    N_Function_Call);
5597       Loc            : constant Source_Ptr := Sloc (N);
5598       Obj            : constant Node_Id    := Prefix (N);
5599       Subprog        : constant Node_Id    :=
5600                          Make_Identifier (Sloc (Selector_Name (N)),
5601                            Chars => Chars (Selector_Name (N)));
5602       --  Identifier on which possible interpretations will be collected
5603
5604       Report_Error : Boolean := False;
5605       --  If no candidate interpretation matches the context, redo the
5606       --  analysis with error enabled to provide additional information.
5607
5608       Actual          : Node_Id;
5609       Candidate       : Entity_Id := Empty;
5610       New_Call_Node   : Node_Id := Empty;
5611       Node_To_Replace : Node_Id;
5612       Obj_Type        : Entity_Id := Etype (Obj);
5613       Success         : Boolean := False;
5614
5615       function Valid_Candidate
5616         (Success : Boolean;
5617          Call    : Node_Id;
5618          Subp    : Entity_Id) return Entity_Id;
5619       --  If the subprogram is a valid interpretation, record it, and add
5620       --  to the list of interpretations of Subprog.
5621
5622       procedure Complete_Object_Operation
5623         (Call_Node       : Node_Id;
5624          Node_To_Replace : Node_Id);
5625       --  Make Subprog the name of Call_Node, replace Node_To_Replace with
5626       --  Call_Node, insert the object (or its dereference) as the first actual
5627       --  in the call, and complete the analysis of the call.
5628
5629       procedure Report_Ambiguity (Op : Entity_Id);
5630       --  If a prefixed procedure call is ambiguous, indicate whether the
5631       --  call includes an implicit dereference or an implicit 'Access.
5632
5633       procedure Transform_Object_Operation
5634         (Call_Node       : out Node_Id;
5635          Node_To_Replace : out Node_Id);
5636       --  Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
5637       --  Call_Node is the resulting subprogram call, Node_To_Replace is
5638       --  either N or the parent of N, and Subprog is a reference to the
5639       --  subprogram we are trying to match.
5640
5641       function Try_Class_Wide_Operation
5642         (Call_Node       : Node_Id;
5643          Node_To_Replace : Node_Id) return Boolean;
5644       --  Traverse all ancestor types looking for a class-wide subprogram
5645       --  for which the current operation is a valid non-dispatching call.
5646
5647       procedure Try_One_Prefix_Interpretation (T : Entity_Id);
5648       --  If prefix is overloaded, its interpretation may include different
5649       --  tagged types, and we must examine the primitive operations and
5650       --  the class-wide operations of each in order to find candidate
5651       --  interpretations for the call as a whole.
5652
5653       function Try_Primitive_Operation
5654         (Call_Node       : Node_Id;
5655          Node_To_Replace : Node_Id) return Boolean;
5656       --  Traverse the list of primitive subprograms looking for a dispatching
5657       --  operation for which the current node is a valid call .
5658
5659       ---------------------
5660       -- Valid_Candidate --
5661       ---------------------
5662
5663       function Valid_Candidate
5664         (Success : Boolean;
5665          Call    : Node_Id;
5666          Subp    : Entity_Id) return Entity_Id
5667       is
5668          Comp_Type : Entity_Id;
5669
5670       begin
5671          --  If the subprogram is a valid interpretation, record it in global
5672          --  variable Subprog, to collect all possible overloadings.
5673
5674          if Success then
5675             if Subp /= Entity (Subprog) then
5676                Add_One_Interp (Subprog, Subp, Etype (Subp));
5677             end if;
5678          end if;
5679
5680          --  If the call may be an indexed call, retrieve component type of
5681          --  resulting expression, and add possible interpretation.
5682
5683          Comp_Type := Empty;
5684
5685          if Nkind (Call) = N_Function_Call
5686            and then Nkind (Parent (N)) = N_Indexed_Component
5687            and then Needs_One_Actual (Subp)
5688          then
5689             if Is_Array_Type (Etype (Subp)) then
5690                Comp_Type := Component_Type (Etype (Subp));
5691
5692             elsif Is_Access_Type (Etype (Subp))
5693               and then Is_Array_Type (Designated_Type (Etype (Subp)))
5694             then
5695                Comp_Type := Component_Type (Designated_Type (Etype (Subp)));
5696             end if;
5697          end if;
5698
5699          if Present (Comp_Type)
5700            and then Etype (Subprog) /= Comp_Type
5701          then
5702             Add_One_Interp (Subprog, Subp, Comp_Type);
5703          end if;
5704
5705          if Etype (Call) /= Any_Type then
5706             return Subp;
5707          else
5708             return Empty;
5709          end if;
5710       end Valid_Candidate;
5711
5712       -------------------------------
5713       -- Complete_Object_Operation --
5714       -------------------------------
5715
5716       procedure Complete_Object_Operation
5717         (Call_Node       : Node_Id;
5718          Node_To_Replace : Node_Id)
5719       is
5720          Control      : constant Entity_Id := First_Formal (Entity (Subprog));
5721          Formal_Type  : constant Entity_Id := Etype (Control);
5722          First_Actual : Node_Id;
5723
5724       begin
5725          --  Place the name of the operation, with its interpretations,
5726          --  on the rewritten call.
5727
5728          Set_Name (Call_Node, Subprog);
5729
5730          First_Actual := First (Parameter_Associations (Call_Node));
5731
5732          --  For cross-reference purposes, treat the new node as being in
5733          --  the source if the original one is.
5734
5735          Set_Comes_From_Source (Subprog, Comes_From_Source (N));
5736          Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
5737
5738          if Nkind (N) = N_Selected_Component
5739            and then not Inside_A_Generic
5740          then
5741             Set_Entity (Selector_Name (N), Entity (Subprog));
5742          end if;
5743
5744          --  If need be, rewrite first actual as an explicit dereference
5745          --  If the call is overloaded, the rewriting can only be done
5746          --  once the primitive operation is identified.
5747
5748          if Is_Overloaded (Subprog) then
5749
5750             --  The prefix itself may be overloaded, and its interpretations
5751             --  must be propagated to the new actual in the call.
5752
5753             if Is_Overloaded (Obj) then
5754                Save_Interps (Obj, First_Actual);
5755             end if;
5756
5757             Rewrite (First_Actual, Obj);
5758
5759          elsif not Is_Access_Type (Formal_Type)
5760            and then Is_Access_Type (Etype (Obj))
5761          then
5762             Rewrite (First_Actual,
5763               Make_Explicit_Dereference (Sloc (Obj), Obj));
5764             Analyze (First_Actual);
5765
5766             --  If we need to introduce an explicit dereference, verify that
5767             --  the resulting actual is compatible with the mode of the formal.
5768
5769             if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter
5770               and then Is_Access_Constant (Etype (Obj))
5771             then
5772                Error_Msg_NE
5773                  ("expect variable in call to&", Prefix (N), Entity (Subprog));
5774             end if;
5775
5776          --  Conversely, if the formal is an access parameter and the object
5777          --  is not, replace the actual with a 'Access reference. Its analysis
5778          --  will check that the object is aliased.
5779
5780          elsif Is_Access_Type (Formal_Type)
5781            and then not Is_Access_Type (Etype (Obj))
5782          then
5783             --  A special case: A.all'access is illegal if A is an access to a
5784             --  constant and the context requires an access to a variable.
5785
5786             if not Is_Access_Constant (Formal_Type) then
5787                if (Nkind (Obj) = N_Explicit_Dereference
5788                     and then Is_Access_Constant (Etype (Prefix (Obj))))
5789                  or else not Is_Variable (Obj)
5790                then
5791                   Error_Msg_NE
5792                     ("actual for& must be a variable", Obj, Control);
5793                end if;
5794             end if;
5795
5796             Rewrite (First_Actual,
5797               Make_Attribute_Reference (Loc,
5798                 Attribute_Name => Name_Access,
5799                 Prefix => Relocate_Node (Obj)));
5800
5801             if not Is_Aliased_View (Obj) then
5802                Error_Msg_NE
5803                  ("object in prefixed call to& must be aliased"
5804                       & " (RM-2005 4.3.1 (13))",
5805                  Prefix (First_Actual), Subprog);
5806             end if;
5807
5808             Analyze (First_Actual);
5809
5810          else
5811             if Is_Overloaded (Obj) then
5812                Save_Interps (Obj, First_Actual);
5813             end if;
5814
5815             Rewrite (First_Actual, Obj);
5816          end if;
5817
5818          Rewrite (Node_To_Replace, Call_Node);
5819
5820          --  Propagate the interpretations collected in subprog to the new
5821          --  function call node, to be resolved from context.
5822
5823          if Is_Overloaded (Subprog) then
5824             Save_Interps (Subprog, Node_To_Replace);
5825          else
5826             Analyze (Node_To_Replace);
5827          end if;
5828       end Complete_Object_Operation;
5829
5830       ----------------------
5831       -- Report_Ambiguity --
5832       ----------------------
5833
5834       procedure Report_Ambiguity (Op : Entity_Id) is
5835          Access_Formal : constant Boolean :=
5836                            Is_Access_Type (Etype (First_Formal (Op)));
5837          Access_Actual : constant Boolean :=
5838                            Is_Access_Type (Etype (Prefix (N)));
5839
5840       begin
5841          Error_Msg_Sloc := Sloc (Op);
5842
5843          if Access_Formal and then not Access_Actual then
5844             if Nkind (Parent (Op)) = N_Full_Type_Declaration then
5845                Error_Msg_N
5846                  ("\possible interpretation"
5847                    & " (inherited, with implicit 'Access) #", N);
5848             else
5849                Error_Msg_N
5850                  ("\possible interpretation (with implicit 'Access) #", N);
5851             end if;
5852
5853          elsif not Access_Formal and then Access_Actual then
5854             if Nkind (Parent (Op)) = N_Full_Type_Declaration then
5855                Error_Msg_N
5856                  ("\possible interpretation"
5857                    & " ( inherited, with implicit dereference) #", N);
5858             else
5859                Error_Msg_N
5860                  ("\possible interpretation (with implicit dereference) #", N);
5861             end if;
5862
5863          else
5864             if Nkind (Parent (Op)) = N_Full_Type_Declaration then
5865                Error_Msg_N ("\possible interpretation (inherited)#", N);
5866             else
5867                Error_Msg_N ("\possible interpretation#", N);
5868             end if;
5869          end if;
5870       end Report_Ambiguity;
5871
5872       --------------------------------
5873       -- Transform_Object_Operation --
5874       --------------------------------
5875
5876       procedure Transform_Object_Operation
5877         (Call_Node       : out Node_Id;
5878          Node_To_Replace : out Node_Id)
5879       is
5880          Dummy : constant Node_Id := New_Copy (Obj);
5881          --  Placeholder used as a first parameter in the call, replaced
5882          --  eventually by the proper object.
5883
5884          Parent_Node : constant Node_Id := Parent (N);
5885
5886          Actual  : Node_Id;
5887          Actuals : List_Id;
5888
5889       begin
5890          --  Common case covering 1) Call to a procedure and 2) Call to a
5891          --  function that has some additional actuals.
5892
5893          if Nkind_In (Parent_Node, N_Function_Call,
5894                                    N_Procedure_Call_Statement)
5895
5896             --  N is a selected component node containing the name of the
5897             --  subprogram. If N is not the name of the parent node we must
5898             --  not replace the parent node by the new construct. This case
5899             --  occurs when N is a parameterless call to a subprogram that
5900             --  is an actual parameter of a call to another subprogram. For
5901             --  example:
5902             --            Some_Subprogram (..., Obj.Operation, ...)
5903
5904             and then Name (Parent_Node) = N
5905          then
5906             Node_To_Replace := Parent_Node;
5907
5908             Actuals := Parameter_Associations (Parent_Node);
5909
5910             if Present (Actuals) then
5911                Prepend (Dummy, Actuals);
5912             else
5913                Actuals := New_List (Dummy);
5914             end if;
5915
5916             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
5917                Call_Node :=
5918                  Make_Procedure_Call_Statement (Loc,
5919                    Name => New_Copy (Subprog),
5920                    Parameter_Associations => Actuals);
5921
5922             else
5923                Call_Node :=
5924                  Make_Function_Call (Loc,
5925                    Name => New_Copy (Subprog),
5926                    Parameter_Associations => Actuals);
5927
5928             end if;
5929
5930          --  Before analysis, a function call appears as an indexed component
5931          --  if there are no named associations.
5932
5933          elsif Nkind (Parent_Node) =  N_Indexed_Component
5934            and then N = Prefix (Parent_Node)
5935          then
5936             Node_To_Replace := Parent_Node;
5937
5938             Actuals := Expressions (Parent_Node);
5939
5940             Actual := First (Actuals);
5941             while Present (Actual) loop
5942                Analyze (Actual);
5943                Next (Actual);
5944             end loop;
5945
5946             Prepend (Dummy, Actuals);
5947
5948             Call_Node :=
5949                Make_Function_Call (Loc,
5950                  Name => New_Copy (Subprog),
5951                  Parameter_Associations => Actuals);
5952
5953          --  Parameterless call: Obj.F is rewritten as F (Obj)
5954
5955          else
5956             Node_To_Replace := N;
5957
5958             Call_Node :=
5959                Make_Function_Call (Loc,
5960                  Name => New_Copy (Subprog),
5961                  Parameter_Associations => New_List (Dummy));
5962          end if;
5963       end Transform_Object_Operation;
5964
5965       ------------------------------
5966       -- Try_Class_Wide_Operation --
5967       ------------------------------
5968
5969       function Try_Class_Wide_Operation
5970         (Call_Node       : Node_Id;
5971          Node_To_Replace : Node_Id) return Boolean
5972       is
5973          Anc_Type    : Entity_Id;
5974          Matching_Op : Entity_Id := Empty;
5975          Error       : Boolean;
5976
5977          procedure Traverse_Homonyms
5978            (Anc_Type : Entity_Id;
5979             Error    : out Boolean);
5980          --  Traverse the homonym chain of the subprogram searching for those
5981          --  homonyms whose first formal has the Anc_Type's class-wide type,
5982          --  or an anonymous access type designating the class-wide type. If
5983          --  an ambiguity is detected, then Error is set to True.
5984
5985          procedure Traverse_Interfaces
5986            (Anc_Type : Entity_Id;
5987             Error    : out Boolean);
5988          --  Traverse the list of interfaces, if any, associated with Anc_Type
5989          --  and search for acceptable class-wide homonyms associated with each
5990          --  interface. If an ambiguity is detected, then Error is set to True.
5991
5992          -----------------------
5993          -- Traverse_Homonyms --
5994          -----------------------
5995
5996          procedure Traverse_Homonyms
5997            (Anc_Type : Entity_Id;
5998             Error    : out Boolean)
5999          is
6000             Cls_Type    : Entity_Id;
6001             Hom         : Entity_Id;
6002             Hom_Ref     : Node_Id;
6003             Success     : Boolean;
6004
6005          begin
6006             Error := False;
6007
6008             Cls_Type := Class_Wide_Type (Anc_Type);
6009
6010             Hom := Current_Entity (Subprog);
6011
6012             --  Find operation whose first parameter is of the class-wide
6013             --  type, a subtype thereof, or an anonymous access to same.
6014
6015             while Present (Hom) loop
6016                if (Ekind (Hom) = E_Procedure
6017                      or else
6018                    Ekind (Hom) = E_Function)
6019                  and then Scope (Hom) = Scope (Anc_Type)
6020                  and then Present (First_Formal (Hom))
6021                  and then
6022                    (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
6023                      or else
6024                        (Is_Access_Type (Etype (First_Formal (Hom)))
6025                           and then
6026                             Ekind (Etype (First_Formal (Hom))) =
6027                               E_Anonymous_Access_Type
6028                           and then
6029                             Base_Type
6030                               (Designated_Type (Etype (First_Formal (Hom)))) =
6031                                                                    Cls_Type))
6032                then
6033                   Set_Etype (Call_Node, Any_Type);
6034                   Set_Is_Overloaded (Call_Node, False);
6035                   Success := False;
6036
6037                   if No (Matching_Op) then
6038                      Hom_Ref := New_Reference_To (Hom, Sloc (Subprog));
6039                      Set_Etype (Call_Node, Any_Type);
6040                      Set_Parent (Call_Node, Parent (Node_To_Replace));
6041
6042                      Set_Name (Call_Node, Hom_Ref);
6043
6044                      Analyze_One_Call
6045                        (N          => Call_Node,
6046                         Nam        => Hom,
6047                         Report     => Report_Error,
6048                         Success    => Success,
6049                         Skip_First => True);
6050
6051                      Matching_Op :=
6052                        Valid_Candidate (Success, Call_Node, Hom);
6053
6054                   else
6055                      Analyze_One_Call
6056                        (N          => Call_Node,
6057                         Nam        => Hom,
6058                         Report     => Report_Error,
6059                         Success    => Success,
6060                         Skip_First => True);
6061
6062                      if Present (Valid_Candidate (Success, Call_Node, Hom))
6063                        and then Nkind (Call_Node) /= N_Function_Call
6064                      then
6065                         Error_Msg_NE ("ambiguous call to&", N, Hom);
6066                         Report_Ambiguity (Matching_Op);
6067                         Report_Ambiguity (Hom);
6068                         Error := True;
6069                         return;
6070                      end if;
6071                   end if;
6072                end if;
6073
6074                Hom := Homonym (Hom);
6075             end loop;
6076          end Traverse_Homonyms;
6077
6078          -------------------------
6079          -- Traverse_Interfaces --
6080          -------------------------
6081
6082          procedure Traverse_Interfaces
6083            (Anc_Type : Entity_Id;
6084             Error    : out Boolean)
6085          is
6086             Intface_List : constant List_Id :=
6087                              Abstract_Interface_List (Anc_Type);
6088             Intface      : Node_Id;
6089
6090          begin
6091             Error := False;
6092
6093             if Is_Non_Empty_List (Intface_List) then
6094                Intface := First (Intface_List);
6095                while Present (Intface) loop
6096
6097                   --  Look for acceptable class-wide homonyms associated with
6098                   --  the interface.
6099
6100                   Traverse_Homonyms (Etype (Intface), Error);
6101
6102                   if Error then
6103                      return;
6104                   end if;
6105
6106                   --  Continue the search by looking at each of the interface's
6107                   --  associated interface ancestors.
6108
6109                   Traverse_Interfaces (Etype (Intface), Error);
6110
6111                   if Error then
6112                      return;
6113                   end if;
6114
6115                   Next (Intface);
6116                end loop;
6117             end if;
6118          end Traverse_Interfaces;
6119
6120       --  Start of processing for Try_Class_Wide_Operation
6121
6122       begin
6123          --  Loop through ancestor types (including interfaces), traversing
6124          --  the homonym chain of the subprogram, trying out those homonyms
6125          --  whose first formal has the class-wide type of the ancestor, or
6126          --  an anonymous access type designating the class-wide type.
6127
6128          Anc_Type := Obj_Type;
6129          loop
6130             --  Look for a match among homonyms associated with the ancestor
6131
6132             Traverse_Homonyms (Anc_Type, Error);
6133
6134             if Error then
6135                return True;
6136             end if;
6137
6138             --  Continue the search for matches among homonyms associated with
6139             --  any interfaces implemented by the ancestor.
6140
6141             Traverse_Interfaces (Anc_Type, Error);
6142
6143             if Error then
6144                return True;
6145             end if;
6146
6147             exit when Etype (Anc_Type) = Anc_Type;
6148             Anc_Type := Etype (Anc_Type);
6149          end loop;
6150
6151          if Present (Matching_Op) then
6152             Set_Etype (Call_Node, Etype (Matching_Op));
6153          end if;
6154
6155          return Present (Matching_Op);
6156       end Try_Class_Wide_Operation;
6157
6158       -----------------------------------
6159       -- Try_One_Prefix_Interpretation --
6160       -----------------------------------
6161
6162       procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
6163       begin
6164          Obj_Type := T;
6165
6166          if Is_Access_Type (Obj_Type) then
6167             Obj_Type := Designated_Type (Obj_Type);
6168          end if;
6169
6170          if Ekind (Obj_Type) = E_Private_Subtype then
6171             Obj_Type := Base_Type (Obj_Type);
6172          end if;
6173
6174          if Is_Class_Wide_Type (Obj_Type) then
6175             Obj_Type := Etype (Class_Wide_Type (Obj_Type));
6176          end if;
6177
6178          --  The type may have be obtained through a limited_with clause,
6179          --  in which case the primitive operations are available on its
6180          --  non-limited view. If still incomplete, retrieve full view.
6181
6182          if Ekind (Obj_Type) = E_Incomplete_Type
6183            and then From_With_Type (Obj_Type)
6184          then
6185             Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type));
6186          end if;
6187
6188          --  If the object is not tagged, or the type is still an incomplete
6189          --  type, this is not a prefixed call.
6190
6191          if not Is_Tagged_Type (Obj_Type)
6192            or else Is_Incomplete_Type (Obj_Type)
6193          then
6194             return;
6195          end if;
6196
6197          if Try_Primitive_Operation
6198               (Call_Node       => New_Call_Node,
6199                Node_To_Replace => Node_To_Replace)
6200            or else
6201              Try_Class_Wide_Operation
6202                (Call_Node       => New_Call_Node,
6203                 Node_To_Replace => Node_To_Replace)
6204          then
6205             null;
6206          end if;
6207       end Try_One_Prefix_Interpretation;
6208
6209       -----------------------------
6210       -- Try_Primitive_Operation --
6211       -----------------------------
6212
6213       function Try_Primitive_Operation
6214         (Call_Node       : Node_Id;
6215          Node_To_Replace : Node_Id) return Boolean
6216       is
6217          Elmt        : Elmt_Id;
6218          Prim_Op     : Entity_Id;
6219          Matching_Op : Entity_Id := Empty;
6220          Prim_Op_Ref : Node_Id   := Empty;
6221
6222          Corr_Type   : Entity_Id := Empty;
6223          --  If the prefix is a synchronized type, the controlling type of
6224          --  the primitive operation is the corresponding record type, else
6225          --  this is the object type itself.
6226
6227          Success     : Boolean   := False;
6228
6229          function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id;
6230          --  For tagged types the candidate interpretations are found in
6231          --  the list of primitive operations of the type and its ancestors.
6232          --  For formal tagged types we have to find the operations declared
6233          --  in the same scope as the type (including in the generic formal
6234          --  part) because the type itself carries no primitive operations,
6235          --  except for formal derived types that inherit the operations of
6236          --  the parent and progenitors.
6237          --  If the context is a generic subprogram body, the generic formals
6238          --  are visible by name, but are not in the entity list of the
6239          --  subprogram because that list starts with the subprogram formals.
6240          --  We retrieve the candidate operations from the generic declaration.
6241
6242          function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
6243          --  Verify that the prefix, dereferenced if need be, is a valid
6244          --  controlling argument in a call to Op. The remaining actuals
6245          --  are checked in the subsequent call to Analyze_One_Call.
6246
6247          ------------------------------
6248          -- Collect_Generic_Type_Ops --
6249          ------------------------------
6250
6251          function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is
6252             Bas        : constant Entity_Id := Base_Type (T);
6253             Candidates : constant Elist_Id := New_Elmt_List;
6254             Subp       : Entity_Id;
6255             Formal     : Entity_Id;
6256
6257             procedure Check_Candidate;
6258             --  The operation is a candidate if its first parameter is a
6259             --  controlling operand of the desired type.
6260
6261             -----------------------
6262             --  Check_Candidate; --
6263             -----------------------
6264
6265             procedure Check_Candidate is
6266             begin
6267                Formal := First_Formal (Subp);
6268
6269                if Present (Formal)
6270                  and then Is_Controlling_Formal (Formal)
6271                  and then
6272                    (Base_Type (Etype (Formal)) = Bas
6273                      or else
6274                        (Is_Access_Type (Etype (Formal))
6275                          and then Designated_Type (Etype (Formal)) = Bas))
6276                then
6277                   Append_Elmt (Subp, Candidates);
6278                end if;
6279             end Check_Candidate;
6280
6281          --  Start of processing for Collect_Generic_Type_Ops
6282
6283          begin
6284             if Is_Derived_Type (T) then
6285                return Primitive_Operations (T);
6286
6287             elsif Ekind (Scope (T)) = E_Procedure
6288               or else Ekind (Scope (T)) = E_Function
6289             then
6290                --  Scan the list of generic formals to find subprograms
6291                --  that may have a first controlling formal of the type.
6292
6293                declare
6294                   Decl : Node_Id;
6295
6296                begin
6297                   Decl :=
6298                     First (Generic_Formal_Declarations
6299                             (Unit_Declaration_Node (Scope (T))));
6300                   while Present (Decl) loop
6301                      if Nkind (Decl) in N_Formal_Subprogram_Declaration then
6302                         Subp := Defining_Entity (Decl);
6303                         Check_Candidate;
6304                      end if;
6305
6306                      Next (Decl);
6307                   end loop;
6308                end;
6309
6310                return Candidates;
6311
6312             else
6313                --  Scan the list of entities declared in the same scope as
6314                --  the type. In general this will be an open scope, given that
6315                --  the call we are analyzing can only appear within a generic
6316                --  declaration or body (either the one that declares T, or a
6317                --  child unit).
6318
6319                Subp := First_Entity (Scope (T));
6320                while Present (Subp) loop
6321                   if Is_Overloadable (Subp) then
6322                      Check_Candidate;
6323                   end if;
6324
6325                   Next_Entity (Subp);
6326                end loop;
6327
6328                return Candidates;
6329             end if;
6330          end Collect_Generic_Type_Ops;
6331
6332          -----------------------------
6333          -- Valid_First_Argument_Of --
6334          -----------------------------
6335
6336          function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
6337             Typ : constant Entity_Id := Etype (First_Formal (Op));
6338
6339          begin
6340             --  Simple case. Object may be a subtype of the tagged type or
6341             --  may be the corresponding record of a synchronized type.
6342
6343             return Obj_Type = Typ
6344               or else Base_Type (Obj_Type) = Typ
6345               or else Corr_Type = Typ
6346
6347                --  Prefix can be dereferenced
6348
6349               or else
6350                 (Is_Access_Type (Corr_Type)
6351                   and then Designated_Type (Corr_Type) = Typ)
6352
6353                --  Formal is an access parameter, for which the object
6354                --  can provide an access.
6355
6356               or else
6357                 (Ekind (Typ) = E_Anonymous_Access_Type
6358                   and then Designated_Type (Typ) = Base_Type (Corr_Type));
6359          end Valid_First_Argument_Of;
6360
6361       --  Start of processing for Try_Primitive_Operation
6362
6363       begin
6364          --  Look for subprograms in the list of primitive operations. The name
6365          --  must be identical, and the kind of call indicates the expected
6366          --  kind of operation (function or procedure). If the type is a
6367          --  (tagged) synchronized type, the primitive ops are attached to the
6368          --  corresponding record (base) type.
6369
6370          if Is_Concurrent_Type (Obj_Type) then
6371             Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
6372             Elmt := First_Elmt (Primitive_Operations (Corr_Type));
6373
6374          elsif not Is_Generic_Type (Obj_Type) then
6375             Corr_Type := Obj_Type;
6376             Elmt := First_Elmt (Primitive_Operations (Obj_Type));
6377
6378          else
6379             Corr_Type := Obj_Type;
6380             Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
6381          end if;
6382
6383          while Present (Elmt) loop
6384             Prim_Op := Node (Elmt);
6385
6386             if Chars (Prim_Op) = Chars (Subprog)
6387               and then Present (First_Formal (Prim_Op))
6388               and then Valid_First_Argument_Of (Prim_Op)
6389               and then
6390                  (Nkind (Call_Node) = N_Function_Call)
6391                    = (Ekind (Prim_Op) = E_Function)
6392             then
6393                --  Ada 2005 (AI-251): If this primitive operation corresponds
6394                --  with an immediate ancestor interface there is no need to add
6395                --  it to the list of interpretations; the corresponding aliased
6396                --  primitive is also in this list of primitive operations and
6397                --  will be used instead.
6398
6399                if (Present (Abstract_Interface_Alias (Prim_Op))
6400                      and then Is_Ancestor (Find_Dispatching_Type
6401                                              (Alias (Prim_Op)), Corr_Type))
6402                  or else
6403
6404                --  Do not consider hidden primitives unless the type is in an
6405                --  open scope or we are within an instance, where visibility
6406                --  is known to be correct.
6407
6408                   (Is_Hidden (Prim_Op)
6409                      and then not Is_Immediately_Visible (Obj_Type)
6410                      and then not In_Instance)
6411                then
6412                   goto Continue;
6413                end if;
6414
6415                Set_Etype (Call_Node, Any_Type);
6416                Set_Is_Overloaded (Call_Node, False);
6417
6418                if No (Matching_Op) then
6419                   Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog));
6420                   Candidate := Prim_Op;
6421
6422                   Set_Parent (Call_Node, Parent (Node_To_Replace));
6423
6424                   Set_Name (Call_Node, Prim_Op_Ref);
6425                   Success := False;
6426
6427                   Analyze_One_Call
6428                     (N          => Call_Node,
6429                      Nam        => Prim_Op,
6430                      Report     => Report_Error,
6431                      Success    => Success,
6432                      Skip_First => True);
6433
6434                   Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op);
6435
6436                --  More than one interpretation, collect for subsequent
6437                --  disambiguation. If this is a procedure call and there
6438                --  is another match, report ambiguity now.
6439
6440                else
6441                   Analyze_One_Call
6442                     (N          => Call_Node,
6443                      Nam        => Prim_Op,
6444                      Report     => Report_Error,
6445                      Success    => Success,
6446                      Skip_First => True);
6447
6448                   if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
6449                     and then Nkind (Call_Node) /= N_Function_Call
6450                   then
6451                      Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
6452                      Report_Ambiguity (Matching_Op);
6453                      Report_Ambiguity (Prim_Op);
6454                      return True;
6455                   end if;
6456                end if;
6457             end if;
6458
6459             <<Continue>>
6460             Next_Elmt (Elmt);
6461          end loop;
6462
6463          if Present (Matching_Op) then
6464             Set_Etype (Call_Node, Etype (Matching_Op));
6465          end if;
6466
6467          return Present (Matching_Op);
6468       end Try_Primitive_Operation;
6469
6470    --  Start of processing for Try_Object_Operation
6471
6472    begin
6473       Analyze_Expression (Obj);
6474
6475       --  Analyze the actuals if node is known to be a subprogram call
6476
6477       if Is_Subprg_Call and then N = Name (Parent (N)) then
6478          Actual := First (Parameter_Associations (Parent (N)));
6479          while Present (Actual) loop
6480             Analyze_Expression (Actual);
6481             Next (Actual);
6482          end loop;
6483       end if;
6484
6485       --  Build a subprogram call node, using a copy of Obj as its first
6486       --  actual. This is a placeholder, to be replaced by an explicit
6487       --  dereference when needed.
6488
6489       Transform_Object_Operation
6490         (Call_Node       => New_Call_Node,
6491          Node_To_Replace => Node_To_Replace);
6492
6493       Set_Etype (New_Call_Node, Any_Type);
6494       Set_Etype (Subprog, Any_Type);
6495       Set_Parent (New_Call_Node, Parent (Node_To_Replace));
6496
6497       if not Is_Overloaded (Obj) then
6498          Try_One_Prefix_Interpretation (Obj_Type);
6499
6500       else
6501          declare
6502             I  : Interp_Index;
6503             It : Interp;
6504          begin
6505             Get_First_Interp (Obj, I, It);
6506             while Present (It.Nam) loop
6507                Try_One_Prefix_Interpretation (It.Typ);
6508                Get_Next_Interp (I, It);
6509             end loop;
6510          end;
6511       end if;
6512
6513       if Etype (New_Call_Node) /= Any_Type then
6514          Complete_Object_Operation
6515            (Call_Node       => New_Call_Node,
6516             Node_To_Replace => Node_To_Replace);
6517          return True;
6518
6519       elsif Present (Candidate) then
6520
6521          --  The argument list is not type correct. Re-analyze with error
6522          --  reporting enabled, and use one of the possible candidates.
6523          --  In All_Errors_Mode, re-analyze all failed interpretations.
6524
6525          if All_Errors_Mode then
6526             Report_Error := True;
6527             if Try_Primitive_Operation
6528                 (Call_Node       => New_Call_Node,
6529                  Node_To_Replace => Node_To_Replace)
6530
6531               or else
6532                 Try_Class_Wide_Operation
6533                   (Call_Node       => New_Call_Node,
6534                    Node_To_Replace => Node_To_Replace)
6535             then
6536                null;
6537             end if;
6538
6539          else
6540             Analyze_One_Call
6541               (N          => New_Call_Node,
6542                Nam        => Candidate,
6543                Report     => True,
6544                Success    => Success,
6545                Skip_First => True);
6546          end if;
6547
6548          --  No need for further errors
6549
6550          return True;
6551
6552       else
6553          --  There was no candidate operation, so report it as an error
6554          --  in the caller: Analyze_Selected_Component.
6555
6556          return False;
6557       end if;
6558    end Try_Object_Operation;
6559
6560    ---------
6561    -- wpo --
6562    ---------
6563
6564    procedure wpo (T : Entity_Id) is
6565       Op : Entity_Id;
6566       E  : Elmt_Id;
6567
6568    begin
6569       if not Is_Tagged_Type (T) then
6570          return;
6571       end if;
6572
6573       E := First_Elmt (Primitive_Operations (Base_Type (T)));
6574       while Present (E) loop
6575          Op := Node (E);
6576          Write_Int (Int (Op));
6577          Write_Str (" === ");
6578          Write_Name (Chars (Op));
6579          Write_Str (" in ");
6580          Write_Name (Chars (Scope (Op)));
6581          Next_Elmt (E);
6582          Write_Eol;
6583       end loop;
6584    end wpo;
6585
6586 end Sem_Ch4;