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