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