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-2004, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Util; use Exp_Util;
  34 with Fname;    use Fname;
  35 with Itypes;   use Itypes;
  36 with Lib;      use Lib;
  37 with Lib.Xref; use Lib.Xref;
  38 with Namet;    use Namet;
  39 with Nlists;   use Nlists;
  40 with Nmake;    use Nmake;
  41 with Opt;      use Opt;
  42 with Output;   use Output;
  43 with Restrict; use Restrict;
  44 with Rident;   use Rident;
  45 with Sem;      use Sem;
  46 with Sem_Cat;  use Sem_Cat;
  47 with Sem_Ch3;  use Sem_Ch3;
  48 with Sem_Ch8;  use Sem_Ch8;
  49 with Sem_Dist; use Sem_Dist;
  50 with Sem_Eval; use Sem_Eval;
  51 with Sem_Res;  use Sem_Res;
  52 with Sem_Util; use Sem_Util;
  53 with Sem_Type; use Sem_Type;
  54 with Stand;    use Stand;
  55 with Sinfo;    use Sinfo;
  56 with Snames;   use Snames;
  57 with Tbuild;   use Tbuild;
  58
  59 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  60
  61 package body Sem_Ch4 is
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    procedure Analyze_Expression (N : Node_Id);
  68    --  For expressions that are not names, this is just a call to analyze.
  69    --  If the expression is a name, it may be a call to a parameterless
  70    --  function, and if so must be converted into an explicit call node
  71    --  and analyzed as such. This deproceduring must be done during the first
  72    --  pass of overload resolution, because otherwise a procedure call with
  73    --  overloaded actuals may fail to resolve. See 4327-001 for an example.
  74
  75    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
  76    --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
  77    --  is an operator name or an expanded name whose selector is an operator
  78    --  name, and one possible interpretation is as a predefined operator.
  79
  80    procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
  81    --  If the prefix of a selected_component is overloaded, the proper
  82    --  interpretation that yields a record type with the proper selector
  83    --  name must be selected.
  84
  85    procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
  86    --  Procedure to analyze a user defined binary operator, which is resolved
  87    --  like a function, but instead of a list of actuals it is presented
  88    --  with the left and right operands of an operator node.
  89
  90    procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
  91    --  Procedure to analyze a user defined unary operator, which is resolved
  92    --  like a function, but instead of a list of actuals, it is presented with
  93    --  the operand of the operator node.
  94
  95    procedure Ambiguous_Operands (N : Node_Id);
  96    --  for equality, membership, and comparison operators with overloaded
  97    --  arguments, list possible interpretations.
  98
  99    procedure Analyze_One_Call
 100       (N       : Node_Id;
 101        Nam     : Entity_Id;
 102        Report  : Boolean;
 103        Success : out Boolean);
 104    --  Check one interpretation of an overloaded subprogram name for
 105    --  compatibility with the types of the actuals in a call. If there is a
 106    --  single interpretation which does not match, post error if Report is
 107    --  set to True.
 108    --
 109    --  Nam is the entity that provides the formals against which the actuals
 110    --  are checked. Nam is either the name of a subprogram, or the internal
 111    --  subprogram type constructed for an access_to_subprogram. If the actuals
 112    --  are compatible with Nam, then Nam is added to the list of candidate
 113    --  interpretations for N, and Success is set to True.
 114
 115    procedure Check_Misspelled_Selector
 116      (Prefix : Entity_Id;
 117       Sel    : Node_Id);
 118    --  Give possible misspelling diagnostic if Sel is likely to be
 119    --  a misspelling of one of the selectors of the Prefix.
 120    --  This is called by Analyze_Selected_Component after producing
 121    --  an invalid selector error message.
 122
 123    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
 124    --  Verify that type T is declared in scope S. Used to find intepretations
 125    --  for operators given by expanded names. This is abstracted as a separate
 126    --  function to handle extensions to System, where S is System, but T is
 127    --  declared in the extension.
 128
 129    procedure Find_Arithmetic_Types
 130      (L, R  : Node_Id;
 131       Op_Id : Entity_Id;
 132       N     : Node_Id);
 133    --  L and R are the operands of an arithmetic operator. Find
 134    --  consistent pairs of interpretations for L and R that have a
 135    --  numeric type consistent with the semantics of the operator.
 136
 137    procedure Find_Comparison_Types
 138      (L, R  : Node_Id;
 139       Op_Id : Entity_Id;
 140       N     : Node_Id);
 141    --  L and R are operands of a comparison operator. Find consistent
 142    --  pairs of interpretations for L and R.
 143
 144    procedure Find_Concatenation_Types
 145      (L, R  : Node_Id;
 146       Op_Id : Entity_Id;
 147       N     : Node_Id);
 148    --  For the four varieties of concatenation
 149
 150    procedure Find_Equality_Types
 151      (L, R  : Node_Id;
 152       Op_Id : Entity_Id;
 153       N     : Node_Id);
 154    --  Ditto for equality operators
 155
 156    procedure Find_Boolean_Types
 157      (L, R  : Node_Id;
 158       Op_Id : Entity_Id;
 159       N     : Node_Id);
 160    --  Ditto for binary logical operations
 161
 162    procedure Find_Negation_Types
 163      (R     : Node_Id;
 164       Op_Id : Entity_Id;
 165       N     : Node_Id);
 166    --  Find consistent interpretation for operand of negation operator
 167
 168    procedure Find_Non_Universal_Interpretations
 169      (N     : Node_Id;
 170       R     : Node_Id;
 171       Op_Id : Entity_Id;
 172       T1    : Entity_Id);
 173    --  For equality and comparison operators, the result is always boolean,
 174    --  and the legality of the operation is determined from the visibility
 175    --  of the operand types. If one of the operands has a universal interpre-
 176    --  tation,  the legality check uses some compatible non-universal
 177    --  interpretation of the other operand. N can be an operator node, or
 178    --  a function call whose name is an operator designator.
 179
 180    procedure Find_Unary_Types
 181      (R     : Node_Id;
 182       Op_Id : Entity_Id;
 183       N     : Node_Id);
 184    --  Unary arithmetic types: plus, minus, abs
 185
 186    procedure Check_Arithmetic_Pair
 187      (T1, T2 : Entity_Id;
 188       Op_Id  : Entity_Id;
 189       N      : Node_Id);
 190    --  Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
 191    --  types for left and right operand. Determine whether they constitute
 192    --  a valid pair for the given operator, and record the corresponding
 193    --  interpretation of the operator node. The node N may be an operator
 194    --  node (the usual case) or a function call whose prefix is an operator
 195    --  designator. In  both cases Op_Id is the operator name itself.
 196
 197    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
 198    --  Give detailed information on overloaded call where none of the
 199    --  interpretations match. N is the call node, Nam the designator for
 200    --  the overloaded entity being called.
 201
 202    function Junk_Operand (N : Node_Id) return Boolean;
 203    --  Test for an operand that is an inappropriate entity (e.g. a package
 204    --  name or a label). If so, issue an error message and return True. If
 205    --  the operand is not an inappropriate entity kind, return False.
 206
 207    procedure Operator_Check (N : Node_Id);
 208    --  Verify that an operator has received some valid interpretation. If none
 209    --  was found, determine whether a use clause would make the operation
 210    --  legal. The variable Candidate_Type (defined in Sem_Type) is set for
 211    --  every type compatible with the operator, even if the operator for the
 212    --  type is not directly visible. The routine uses this type to emit a more
 213    --  informative message.
 214
 215    procedure Process_Implicit_Dereference_Prefix
 216      (E : Entity_Id;
 217       P : Node_Id);
 218    --  Called when P is the prefix of an implicit dereference, denoting an
 219    --  object E. If in semantics only mode (-gnatc), record that is a
 220    --  reference to E. Normally, such a reference is generated only when the
 221    --  implicit dereference is expanded into an explicit one. E may be empty,
 222    --  in which case this procedure does nothing.
 223
 224    procedure Remove_Abstract_Operations (N : Node_Id);
 225    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
 226    --  operation is not a candidate interpretation.
 227
 228    function Try_Indexed_Call
 229      (N   : Node_Id;
 230       Nam : Entity_Id;
 231       Typ : Entity_Id) return Boolean;
 232    --  If a function has defaults for all its actuals, a call to it may
 233    --  in fact be an indexing on the result of the call. Try_Indexed_Call
 234    --  attempts the interpretation as an indexing, prior to analysis as
 235    --  a call. If both are possible,  the node is overloaded with both
 236    --  interpretations (same symbol but two different types).
 237
 238    function Try_Indirect_Call
 239      (N   : Node_Id;
 240       Nam : Entity_Id;
 241       Typ : Entity_Id) return Boolean;
 242    --  Similarly, a function F that needs no actuals can return an access
 243    --  to a subprogram, and the call F (X)  interpreted as F.all (X). In
 244    --  this case the call may be overloaded with both interpretations.
 245
 246    function Try_Object_Operation (N : Node_Id) return Boolean;
 247    --  Ada 2005 (AI-252): Give support to the object operation notation
 248
 249    ------------------------
 250    -- Ambiguous_Operands --
 251    ------------------------
 252
 253    procedure Ambiguous_Operands (N : Node_Id) is
 254       procedure List_Operand_Interps (Opnd : Node_Id);
 255
 256       --------------------------
 257       -- List_Operand_Interps --
 258       --------------------------
 259
 260       procedure List_Operand_Interps (Opnd : Node_Id) is
 261          Nam   : Node_Id;
 262          Err   : Node_Id := N;
 263
 264       begin
 265          if Is_Overloaded (Opnd) then
 266             if Nkind (Opnd) in N_Op then
 267                Nam := Opnd;
 268             elsif Nkind (Opnd) = N_Function_Call then
 269                Nam := Name (Opnd);
 270             else
 271                return;
 272             end if;
 273
 274          else
 275             return;
 276          end if;
 277
 278          if Opnd = Left_Opnd (N) then
 279             Error_Msg_N
 280               ("\left operand has the following interpretations", N);
 281          else
 282             Error_Msg_N
 283               ("\right operand has the following interpretations", N);
 284             Err := Opnd;
 285          end if;
 286
 287          List_Interps (Nam, Err);
 288       end List_Operand_Interps;
 289
 290    --  Start of processing for Ambiguous_Operands
 291
 292    begin
 293       if Nkind (N) = N_In
 294         or else Nkind (N) = N_Not_In
 295       then
 296          Error_Msg_N ("ambiguous operands for membership",  N);
 297
 298       elsif Nkind (N) = N_Op_Eq
 299         or else Nkind (N) = N_Op_Ne
 300       then
 301          Error_Msg_N ("ambiguous operands for equality",  N);
 302
 303       else
 304          Error_Msg_N ("ambiguous operands for comparison",  N);
 305       end if;
 306
 307       if All_Errors_Mode then
 308          List_Operand_Interps (Left_Opnd  (N));
 309          List_Operand_Interps (Right_Opnd (N));
 310       else
 311          Error_Msg_N ("\use -gnatf switch for details", N);
 312       end if;
 313    end Ambiguous_Operands;
 314
 315    -----------------------
 316    -- Analyze_Aggregate --
 317    -----------------------
 318
 319    --  Most of the analysis of Aggregates requires that the type be known,
 320    --  and is therefore put off until resolution.
 321
 322    procedure Analyze_Aggregate (N : Node_Id) is
 323    begin
 324       if No (Etype (N)) then
 325          Set_Etype (N, Any_Composite);
 326       end if;
 327    end Analyze_Aggregate;
 328
 329    -----------------------
 330    -- Analyze_Allocator --
 331    -----------------------
 332
 333    procedure Analyze_Allocator (N : Node_Id) is
 334       Loc      : constant Source_Ptr := Sloc (N);
 335       Sav_Errs : constant Nat        := Serious_Errors_Detected;
 336       E        : Node_Id            := Expression (N);
 337       Acc_Type : Entity_Id;
 338       Type_Id  : Entity_Id;
 339
 340    begin
 341       Check_Restriction (No_Allocators, N);
 342
 343       if Nkind (E) = N_Qualified_Expression then
 344          Acc_Type := Create_Itype (E_Allocator_Type, N);
 345          Set_Etype (Acc_Type, Acc_Type);
 346          Init_Size_Align (Acc_Type);
 347          Find_Type (Subtype_Mark (E));
 348          Type_Id := Entity (Subtype_Mark (E));
 349          Check_Fully_Declared (Type_Id, N);
 350          Set_Directly_Designated_Type (Acc_Type, Type_Id);
 351
 352          if Is_Limited_Type (Type_Id)
 353            and then Comes_From_Source (N)
 354            and then not In_Instance_Body
 355          then
 356             --  Ada 2005 (AI-287): Do not post an error if the expression
 357             --  corresponds to a limited aggregate. Limited aggregates
 358             --  are checked in sem_aggr in a per-component manner
 359             --  (compare with handling of Get_Value subprogram).
 360
 361             if Ada_Version >= Ada_05
 362               and then Nkind (Expression (E)) = N_Aggregate
 363             then
 364                null;
 365             else
 366                Error_Msg_N ("initialization not allowed for limited types", N);
 367                Explain_Limited_Type (Type_Id, N);
 368             end if;
 369          end if;
 370
 371          Analyze_And_Resolve (Expression (E), Type_Id);
 372
 373          --  A qualified expression requires an exact match of the type,
 374          --  class-wide matching is not allowed.
 375
 376          if Is_Class_Wide_Type (Type_Id)
 377            and then Base_Type (Etype (Expression (E))) /= Base_Type (Type_Id)
 378          then
 379             Wrong_Type (Expression (E), Type_Id);
 380          end if;
 381
 382          Check_Non_Static_Context (Expression (E));
 383
 384          --  We don't analyze the qualified expression itself because it's
 385          --  part of the allocator
 386
 387          Set_Etype  (E, Type_Id);
 388
 389       --  Case where no qualified expression is present
 390
 391       else
 392          declare
 393             Def_Id : Entity_Id;
 394
 395          begin
 396             --  If the allocator includes a N_Subtype_Indication then a
 397             --  constraint is present, otherwise the node is a subtype mark.
 398             --  Introduce an explicit subtype declaration into the tree
 399             --  defining some anonymous subtype and rewrite the allocator to
 400             --  use this subtype rather than the subtype indication.
 401
 402             --  It is important to introduce the explicit subtype declaration
 403             --  so that the bounds of the subtype indication are attached to
 404             --  the tree in case the allocator is inside a generic unit.
 405
 406             if Nkind (E) = N_Subtype_Indication then
 407
 408                --  A constraint is only allowed for a composite type in Ada
 409                --  95. In Ada 83, a constraint is also allowed for an
 410                --  access-to-composite type, but the constraint is ignored.
 411
 412                Find_Type (Subtype_Mark (E));
 413
 414                if Is_Elementary_Type (Entity (Subtype_Mark (E))) then
 415                   if not (Ada_Version = Ada_83
 416                            and then Is_Access_Type (Entity (Subtype_Mark (E))))
 417                   then
 418                      Error_Msg_N ("constraint not allowed here", E);
 419
 420                      if Nkind (Constraint (E))
 421                        = N_Index_Or_Discriminant_Constraint
 422                      then
 423                         Error_Msg_N
 424                           ("\if qualified expression was meant, " &
 425                               "use apostrophe", Constraint (E));
 426                      end if;
 427                   end if;
 428
 429                   --  Get rid of the bogus constraint:
 430
 431                   Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
 432                   Analyze_Allocator (N);
 433                   return;
 434                end if;
 435
 436                if Expander_Active then
 437                   Def_Id :=
 438                     Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 439
 440                   Insert_Action (E,
 441                     Make_Subtype_Declaration (Loc,
 442                       Defining_Identifier => Def_Id,
 443                       Subtype_Indication  => Relocate_Node (E)));
 444
 445                   if Sav_Errs /= Serious_Errors_Detected
 446                     and then Nkind (Constraint (E))
 447                       = N_Index_Or_Discriminant_Constraint
 448                   then
 449                      Error_Msg_N
 450                        ("if qualified expression was meant, " &
 451                            "use apostrophe!", Constraint (E));
 452                   end if;
 453
 454                   E := New_Occurrence_Of (Def_Id, Loc);
 455                   Rewrite (Expression (N), E);
 456                end if;
 457             end if;
 458
 459             Type_Id := Process_Subtype (E, N);
 460             Acc_Type := Create_Itype (E_Allocator_Type, N);
 461             Set_Etype                    (Acc_Type, Acc_Type);
 462             Init_Size_Align              (Acc_Type);
 463             Set_Directly_Designated_Type (Acc_Type, Type_Id);
 464             Check_Fully_Declared (Type_Id, N);
 465
 466             --  Ada 2005 (AI-231)
 467
 468             if Can_Never_Be_Null (Type_Id) then
 469                Error_Msg_N ("(Ada 2005) qualified expression required",
 470                             Expression (N));
 471             end if;
 472
 473             --  Check restriction against dynamically allocated protected
 474             --  objects. Note that when limited aggregates are supported,
 475             --  a similar test should be applied to an allocator with a
 476             --  qualified expression ???
 477
 478             if Is_Protected_Type (Type_Id) then
 479                Check_Restriction (No_Protected_Type_Allocators, N);
 480             end if;
 481
 482             --  Check for missing initialization. Skip this check if we already
 483             --  had errors on analyzing the allocator, since in that case these
 484             --  are probably cascaded errors
 485
 486             if Is_Indefinite_Subtype (Type_Id)
 487               and then Serious_Errors_Detected = Sav_Errs
 488             then
 489                if Is_Class_Wide_Type (Type_Id) then
 490                   Error_Msg_N
 491                     ("initialization required in class-wide allocation", N);
 492                else
 493                   Error_Msg_N
 494                     ("initialization required in unconstrained allocation", N);
 495                end if;
 496             end if;
 497          end;
 498       end if;
 499
 500       if Is_Abstract (Type_Id) then
 501          Error_Msg_N ("cannot allocate abstract object", E);
 502       end if;
 503
 504       if Has_Task (Designated_Type (Acc_Type)) then
 505          Check_Restriction (No_Tasking, N);
 506          Check_Restriction (Max_Tasks, N);
 507          Check_Restriction (No_Task_Allocators, N);
 508       end if;
 509
 510       --  If the No_Streams restriction is set, check that the type of the
 511       --  object is not, and does not contain, any subtype derived from
 512       --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
 513       --  Has_Stream just for efficiency reasons. There is no point in
 514       --  spending time on a Has_Stream check if the restriction is not set.
 515
 516       if Restrictions.Set (No_Streams) then
 517          if Has_Stream (Designated_Type (Acc_Type)) then
 518             Check_Restriction (No_Streams, N);
 519          end if;
 520       end if;
 521
 522       Set_Etype (N, Acc_Type);
 523
 524       if not Is_Library_Level_Entity (Acc_Type) then
 525          Check_Restriction (No_Local_Allocators, N);
 526       end if;
 527
 528       --  Ada 2005 (AI-231): Static checks
 529
 530       if Ada_Version >= Ada_05
 531         and then (Null_Exclusion_Present (N)
 532                     or else Can_Never_Be_Null (Etype (N)))
 533       then
 534          Null_Exclusion_Static_Checks (N);
 535       end if;
 536
 537       if Serious_Errors_Detected > Sav_Errs then
 538          Set_Error_Posted (N);
 539          Set_Etype (N, Any_Type);
 540       end if;
 541    end Analyze_Allocator;
 542
 543    ---------------------------
 544    -- Analyze_Arithmetic_Op --
 545    ---------------------------
 546
 547    procedure Analyze_Arithmetic_Op (N : Node_Id) is
 548       L     : constant Node_Id := Left_Opnd (N);
 549       R     : constant Node_Id := Right_Opnd (N);
 550       Op_Id : Entity_Id;
 551
 552    begin
 553       Candidate_Type := Empty;
 554       Analyze_Expression (L);
 555       Analyze_Expression (R);
 556
 557       --  If the entity is already set, the node is the instantiation of
 558       --  a generic node with a non-local reference, or was manufactured
 559       --  by a call to Make_Op_xxx. In either case the entity is known to
 560       --  be valid, and we do not need to collect interpretations, instead
 561       --  we just get the single possible interpretation.
 562
 563       Op_Id := Entity (N);
 564
 565       if Present (Op_Id) then
 566          if Ekind (Op_Id) = E_Operator then
 567
 568             if (Nkind (N) = N_Op_Divide   or else
 569                 Nkind (N) = N_Op_Mod      or else
 570                 Nkind (N) = N_Op_Multiply or else
 571                 Nkind (N) = N_Op_Rem)
 572               and then Treat_Fixed_As_Integer (N)
 573             then
 574                null;
 575             else
 576                Set_Etype (N, Any_Type);
 577                Find_Arithmetic_Types (L, R, Op_Id, N);
 578             end if;
 579
 580          else
 581             Set_Etype (N, Any_Type);
 582             Add_One_Interp (N, Op_Id, Etype (Op_Id));
 583          end if;
 584
 585       --  Entity is not already set, so we do need to collect interpretations
 586
 587       else
 588          Op_Id := Get_Name_Entity_Id (Chars (N));
 589          Set_Etype (N, Any_Type);
 590
 591          while Present (Op_Id) loop
 592             if Ekind (Op_Id) = E_Operator
 593               and then Present (Next_Entity (First_Entity (Op_Id)))
 594             then
 595                Find_Arithmetic_Types (L, R, Op_Id, N);
 596
 597             --  The following may seem superfluous, because an operator cannot
 598             --  be generic, but this ignores the cleverness of the author of
 599             --  ACVC bc1013a.
 600
 601             elsif Is_Overloadable (Op_Id) then
 602                Analyze_User_Defined_Binary_Op (N, Op_Id);
 603             end if;
 604
 605             Op_Id := Homonym (Op_Id);
 606          end loop;
 607       end if;
 608
 609       Operator_Check (N);
 610    end Analyze_Arithmetic_Op;
 611
 612    ------------------
 613    -- Analyze_Call --
 614    ------------------
 615
 616    --  Function, procedure, and entry calls are checked here. The Name in
 617    --  the call may be overloaded. The actuals have been analyzed and may
 618    --  themselves be overloaded. On exit from this procedure, the node N
 619    --  may have zero, one or more interpretations. In the first case an
 620    --  error message is produced. In the last case, the node is flagged
 621    --  as overloaded and the interpretations are collected in All_Interp.
 622
 623    --  If the name is an Access_To_Subprogram, it cannot be overloaded, but
 624    --  the type-checking is similar to that of other calls.
 625
 626    procedure Analyze_Call (N : Node_Id) is
 627       Actuals : constant List_Id := Parameter_Associations (N);
 628       Nam     : Node_Id          := Name (N);
 629       X       : Interp_Index;
 630       It      : Interp;
 631       Nam_Ent : Entity_Id;
 632       Success : Boolean := False;
 633
 634       function Name_Denotes_Function return Boolean;
 635       --  If the type of the name is an access to subprogram, this may be
 636       --  the type of a name, or the return type of the function being called.
 637       --  If the name is not an entity then it can denote a protected function.
 638       --  Until we distinguish Etype from Return_Type, we must use this
 639       --  routine to resolve the meaning of the name in the call.
 640
 641       ---------------------------
 642       -- Name_Denotes_Function --
 643       ---------------------------
 644
 645       function Name_Denotes_Function return Boolean is
 646       begin
 647          if Is_Entity_Name (Nam) then
 648             return Ekind (Entity (Nam)) = E_Function;
 649
 650          elsif Nkind (Nam) = N_Selected_Component then
 651             return Ekind (Entity (Selector_Name (Nam))) = E_Function;
 652
 653          else
 654             return False;
 655          end if;
 656       end Name_Denotes_Function;
 657
 658    --  Start of processing for Analyze_Call
 659
 660    begin
 661       --  Initialize the type of the result of the call to the error type,
 662       --  which will be reset if the type is successfully resolved.
 663
 664       Set_Etype (N, Any_Type);
 665
 666       if not Is_Overloaded (Nam) then
 667
 668          --  Only one interpretation to check
 669
 670          if Ekind (Etype (Nam)) = E_Subprogram_Type then
 671             Nam_Ent := Etype (Nam);
 672
 673          elsif Is_Access_Type (Etype (Nam))
 674            and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
 675            and then not Name_Denotes_Function
 676          then
 677             Nam_Ent := Designated_Type (Etype (Nam));
 678             Insert_Explicit_Dereference (Nam);
 679
 680          --  Selected component case. Simple entry or protected operation,
 681          --  where the entry name is given by the selector name.
 682
 683          elsif Nkind (Nam) = N_Selected_Component then
 684             Nam_Ent := Entity (Selector_Name (Nam));
 685
 686             if Ekind (Nam_Ent) /= E_Entry
 687               and then Ekind (Nam_Ent) /= E_Entry_Family
 688               and then Ekind (Nam_Ent) /= E_Function
 689               and then Ekind (Nam_Ent) /= E_Procedure
 690             then
 691                Error_Msg_N ("name in call is not a callable entity", Nam);
 692                Set_Etype (N, Any_Type);
 693                return;
 694             end if;
 695
 696          --  If the name is an Indexed component, it can be a call to a member
 697          --  of an entry family. The prefix must be a selected component whose
 698          --  selector is the entry. Analyze_Procedure_Call normalizes several
 699          --  kinds of call into this form.
 700
 701          elsif Nkind (Nam) = N_Indexed_Component then
 702
 703             if Nkind (Prefix (Nam)) = N_Selected_Component then
 704                Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
 705             else
 706                Error_Msg_N ("name in call is not a callable entity", Nam);
 707                Set_Etype (N, Any_Type);
 708                return;
 709             end if;
 710
 711          elsif not Is_Entity_Name (Nam) then
 712             Error_Msg_N ("name in call is not a callable entity", Nam);
 713             Set_Etype (N, Any_Type);
 714             return;
 715
 716          else
 717             Nam_Ent := Entity (Nam);
 718
 719             --  If no interpretations, give error message
 720
 721             if not Is_Overloadable (Nam_Ent) then
 722                declare
 723                   L : constant Boolean   := Is_List_Member (N);
 724                   K : constant Node_Kind := Nkind (Parent (N));
 725
 726                begin
 727                   --  If the node is in a list whose parent is not an
 728                   --  expression then it must be an attempted procedure call.
 729
 730                   if L and then K not in N_Subexpr then
 731                      if Ekind (Entity (Nam)) = E_Generic_Procedure then
 732                         Error_Msg_NE
 733                           ("must instantiate generic procedure& before call",
 734                            Nam, Entity (Nam));
 735                      else
 736                         Error_Msg_N
 737                           ("procedure or entry name expected", Nam);
 738                      end if;
 739
 740                   --  Check for tasking cases where only an entry call will do
 741
 742                   elsif not L
 743                     and then (K = N_Entry_Call_Alternative
 744                                or else K = N_Triggering_Alternative)
 745                   then
 746                      Error_Msg_N ("entry name expected", Nam);
 747
 748                   --  Otherwise give general error message
 749
 750                   else
 751                      Error_Msg_N ("invalid prefix in call", Nam);
 752                   end if;
 753
 754                   return;
 755                end;
 756             end if;
 757          end if;
 758
 759          Analyze_One_Call (N, Nam_Ent, True, Success);
 760
 761       else
 762          --  An overloaded selected component must denote overloaded
 763          --  operations of a concurrent type. The interpretations are
 764          --  attached to the simple name of those operations.
 765
 766          if Nkind (Nam) = N_Selected_Component then
 767             Nam := Selector_Name (Nam);
 768          end if;
 769
 770          Get_First_Interp (Nam, X, It);
 771
 772          while Present (It.Nam) loop
 773             Nam_Ent := It.Nam;
 774
 775             --  Name may be call that returns an access to subprogram, or more
 776             --  generally an overloaded expression one of whose interpretations
 777             --  yields an access to subprogram. If the name is an entity, we
 778             --  do not dereference, because the node is a call that returns
 779             --  the access type: note difference between f(x), where the call
 780             --  may return an access subprogram type, and f(x)(y), where the
 781             --  type returned by the call to f is implicitly dereferenced to
 782             --  analyze the outer call.
 783
 784             if Is_Access_Type (Nam_Ent) then
 785                Nam_Ent := Designated_Type (Nam_Ent);
 786
 787             elsif Is_Access_Type (Etype (Nam_Ent))
 788               and then not Is_Entity_Name (Nam)
 789               and then Ekind (Designated_Type (Etype (Nam_Ent)))
 790                                                           = E_Subprogram_Type
 791             then
 792                Nam_Ent := Designated_Type (Etype (Nam_Ent));
 793             end if;
 794
 795             Analyze_One_Call (N, Nam_Ent, False, Success);
 796
 797             --  If the interpretation succeeds, mark the proper type of the
 798             --  prefix (any valid candidate will do). If not, remove the
 799             --  candidate interpretation. This only needs to be done for
 800             --  overloaded protected operations, for other entities disambi-
 801             --  guation is done directly in Resolve.
 802
 803             if Success then
 804                Set_Etype (Nam, It.Typ);
 805
 806             elsif Nkind (Name (N)) = N_Selected_Component
 807               or else Nkind (Name (N)) = N_Function_Call
 808             then
 809                Remove_Interp (X);
 810             end if;
 811
 812             Get_Next_Interp (X, It);
 813          end loop;
 814
 815          --  If the name is the result of a function call, it can only
 816          --  be a call to a function returning an access to subprogram.
 817          --  Insert explicit dereference.
 818
 819          if Nkind (Nam) = N_Function_Call then
 820             Insert_Explicit_Dereference (Nam);
 821          end if;
 822
 823          if Etype (N) = Any_Type then
 824
 825             --  None of the interpretations is compatible with the actuals
 826
 827             Diagnose_Call (N, Nam);
 828
 829             --  Special checks for uninstantiated put routines
 830
 831             if Nkind (N) = N_Procedure_Call_Statement
 832               and then Is_Entity_Name (Nam)
 833               and then Chars (Nam) = Name_Put
 834               and then List_Length (Actuals) = 1
 835             then
 836                declare
 837                   Arg : constant Node_Id := First (Actuals);
 838                   Typ : Entity_Id;
 839
 840                begin
 841                   if Nkind (Arg) = N_Parameter_Association then
 842                      Typ := Etype (Explicit_Actual_Parameter (Arg));
 843                   else
 844                      Typ := Etype (Arg);
 845                   end if;
 846
 847                   if Is_Signed_Integer_Type (Typ) then
 848                      Error_Msg_N
 849                        ("possible missing instantiation of " &
 850                           "'Text_'I'O.'Integer_'I'O!", Nam);
 851
 852                   elsif Is_Modular_Integer_Type (Typ) then
 853                      Error_Msg_N
 854                        ("possible missing instantiation of " &
 855                           "'Text_'I'O.'Modular_'I'O!", Nam);
 856
 857                   elsif Is_Floating_Point_Type (Typ) then
 858                      Error_Msg_N
 859                        ("possible missing instantiation of " &
 860                           "'Text_'I'O.'Float_'I'O!", Nam);
 861
 862                   elsif Is_Ordinary_Fixed_Point_Type (Typ) then
 863                      Error_Msg_N
 864                        ("possible missing instantiation of " &
 865                           "'Text_'I'O.'Fixed_'I'O!", Nam);
 866
 867                   elsif Is_Decimal_Fixed_Point_Type (Typ) then
 868                      Error_Msg_N
 869                        ("possible missing instantiation of " &
 870                           "'Text_'I'O.'Decimal_'I'O!", Nam);
 871
 872                   elsif Is_Enumeration_Type (Typ) then
 873                      Error_Msg_N
 874                        ("possible missing instantiation of " &
 875                           "'Text_'I'O.'Enumeration_'I'O!", Nam);
 876                   end if;
 877                end;
 878             end if;
 879
 880          elsif not Is_Overloaded (N)
 881            and then Is_Entity_Name (Nam)
 882          then
 883             --  Resolution yields a single interpretation. Verify that
 884             --  is has the proper capitalization.
 885
 886             Set_Entity_With_Style_Check (Nam, Entity (Nam));
 887             Generate_Reference (Entity (Nam), Nam);
 888
 889             Set_Etype (Nam, Etype (Entity (Nam)));
 890          else
 891             Remove_Abstract_Operations (N);
 892          end if;
 893
 894          End_Interp_List;
 895       end if;
 896    end Analyze_Call;
 897
 898    ---------------------------
 899    -- Analyze_Comparison_Op --
 900    ---------------------------
 901
 902    procedure Analyze_Comparison_Op (N : Node_Id) is
 903       L     : constant Node_Id := Left_Opnd (N);
 904       R     : constant Node_Id := Right_Opnd (N);
 905       Op_Id : Entity_Id        := Entity (N);
 906
 907    begin
 908       Set_Etype (N, Any_Type);
 909       Candidate_Type := Empty;
 910
 911       Analyze_Expression (L);
 912       Analyze_Expression (R);
 913
 914       if Present (Op_Id) then
 915          if Ekind (Op_Id) = E_Operator then
 916             Find_Comparison_Types (L, R, Op_Id, N);
 917          else
 918             Add_One_Interp (N, Op_Id, Etype (Op_Id));
 919          end if;
 920
 921          if Is_Overloaded (L) then
 922             Set_Etype (L, Intersect_Types (L, R));
 923          end if;
 924
 925       else
 926          Op_Id := Get_Name_Entity_Id (Chars (N));
 927          while Present (Op_Id) loop
 928             if Ekind (Op_Id) = E_Operator then
 929                Find_Comparison_Types (L, R, Op_Id, N);
 930             else
 931                Analyze_User_Defined_Binary_Op (N, Op_Id);
 932             end if;
 933
 934             Op_Id := Homonym (Op_Id);
 935          end loop;
 936       end if;
 937
 938       Operator_Check (N);
 939    end Analyze_Comparison_Op;
 940
 941    ---------------------------
 942    -- Analyze_Concatenation --
 943    ---------------------------
 944
 945    --  If the only one-dimensional array type in scope is String,
 946    --  this is the resulting type of the operation. Otherwise there
 947    --  will be a concatenation operation defined for each user-defined
 948    --  one-dimensional array.
 949
 950    procedure Analyze_Concatenation (N : Node_Id) is
 951       L     : constant Node_Id := Left_Opnd (N);
 952       R     : constant Node_Id := Right_Opnd (N);
 953       Op_Id : Entity_Id        := Entity (N);
 954       LT    : Entity_Id;
 955       RT    : Entity_Id;
 956
 957    begin
 958       Set_Etype (N, Any_Type);
 959       Candidate_Type := Empty;
 960
 961       Analyze_Expression (L);
 962       Analyze_Expression (R);
 963
 964       --  If the entity is present, the  node appears in an instance,
 965       --  and denotes a predefined concatenation operation. The resulting
 966       --  type is obtained from the arguments when possible. If the arguments
 967       --  are aggregates, the array type and the concatenation type must be
 968       --  visible.
 969
 970       if Present (Op_Id) then
 971          if Ekind (Op_Id) = E_Operator then
 972
 973             LT := Base_Type (Etype (L));
 974             RT := Base_Type (Etype (R));
 975
 976             if Is_Array_Type (LT)
 977               and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
 978             then
 979                Add_One_Interp (N, Op_Id, LT);
 980
 981             elsif Is_Array_Type (RT)
 982               and then LT = Base_Type (Component_Type (RT))
 983             then
 984                Add_One_Interp (N, Op_Id, RT);
 985
 986             --  If one operand is a string type or a user-defined array type,
 987             --  and the other is a literal, result is of the specific type.
 988
 989             elsif
 990               (Root_Type (LT) = Standard_String
 991                  or else Scope (LT) /= Standard_Standard)
 992               and then Etype (R) = Any_String
 993             then
 994                Add_One_Interp (N, Op_Id, LT);
 995
 996             elsif
 997               (Root_Type (RT) = Standard_String
 998                  or else Scope (RT) /= Standard_Standard)
 999               and then Etype (L) = Any_String
1000             then
1001                Add_One_Interp (N, Op_Id, RT);
1002
1003             elsif not Is_Generic_Type (Etype (Op_Id)) then
1004                Add_One_Interp (N, Op_Id, Etype (Op_Id));
1005
1006             else
1007                --  Type and its operations must be visible
1008
1009                Set_Entity (N, Empty);
1010                Analyze_Concatenation (N);
1011             end if;
1012
1013          else
1014             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1015          end if;
1016
1017       else
1018          Op_Id  := Get_Name_Entity_Id (Name_Op_Concat);
1019          while Present (Op_Id) loop
1020             if Ekind (Op_Id) = E_Operator then
1021                Find_Concatenation_Types (L, R, Op_Id, N);
1022             else
1023                Analyze_User_Defined_Binary_Op (N, Op_Id);
1024             end if;
1025
1026             Op_Id := Homonym (Op_Id);
1027          end loop;
1028       end if;
1029
1030       Operator_Check (N);
1031    end Analyze_Concatenation;
1032
1033    ------------------------------------
1034    -- Analyze_Conditional_Expression --
1035    ------------------------------------
1036
1037    procedure Analyze_Conditional_Expression (N : Node_Id) is
1038       Condition : constant Node_Id := First (Expressions (N));
1039       Then_Expr : constant Node_Id := Next (Condition);
1040       Else_Expr : constant Node_Id := Next (Then_Expr);
1041    begin
1042       Analyze_Expression (Condition);
1043       Analyze_Expression (Then_Expr);
1044       Analyze_Expression (Else_Expr);
1045       Set_Etype (N, Etype (Then_Expr));
1046    end Analyze_Conditional_Expression;
1047
1048    -------------------------
1049    -- Analyze_Equality_Op --
1050    -------------------------
1051
1052    procedure Analyze_Equality_Op (N : Node_Id) is
1053       Loc   : constant Source_Ptr := Sloc (N);
1054       L     : constant Node_Id := Left_Opnd (N);
1055       R     : constant Node_Id := Right_Opnd (N);
1056       Op_Id : Entity_Id;
1057
1058    begin
1059       Set_Etype (N, Any_Type);
1060       Candidate_Type := Empty;
1061
1062       Analyze_Expression (L);
1063       Analyze_Expression (R);
1064
1065       --  If the entity is set, the node is a generic instance with a non-local
1066       --  reference to the predefined operator or to a user-defined function.
1067       --  It can also be an inequality that is expanded into the negation of a
1068       --  call to a user-defined equality operator.
1069
1070       --  For the predefined case, the result is Boolean, regardless of the
1071       --  type of the  operands. The operands may even be limited, if they are
1072       --  generic actuals. If they are overloaded, label the left argument with
1073       --  the common type that must be present, or with the type of the formal
1074       --  of the user-defined function.
1075
1076       if Present (Entity (N)) then
1077          Op_Id := Entity (N);
1078
1079          if Ekind (Op_Id) = E_Operator then
1080             Add_One_Interp (N, Op_Id, Standard_Boolean);
1081          else
1082             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1083          end if;
1084
1085          if Is_Overloaded (L) then
1086             if Ekind (Op_Id) = E_Operator then
1087                Set_Etype (L, Intersect_Types (L, R));
1088             else
1089                Set_Etype (L, Etype (First_Formal (Op_Id)));
1090             end if;
1091          end if;
1092
1093       else
1094          Op_Id := Get_Name_Entity_Id (Chars (N));
1095          while Present (Op_Id) loop
1096             if Ekind (Op_Id) = E_Operator then
1097                Find_Equality_Types (L, R, Op_Id, N);
1098             else
1099                Analyze_User_Defined_Binary_Op (N, Op_Id);
1100             end if;
1101
1102             Op_Id := Homonym (Op_Id);
1103          end loop;
1104       end if;
1105
1106       --  If there was no match, and the operator is inequality, this may
1107       --  be a case where inequality has not been made explicit, as for
1108       --  tagged types. Analyze the node as the negation of an equality
1109       --  operation. This cannot be done earlier, because before analysis
1110       --  we cannot rule out the presence of an explicit inequality.
1111
1112       if Etype (N) = Any_Type
1113         and then Nkind (N) = N_Op_Ne
1114       then
1115          Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
1116
1117          while Present (Op_Id) loop
1118
1119             if Ekind (Op_Id) = E_Operator then
1120                Find_Equality_Types (L, R, Op_Id, N);
1121             else
1122                Analyze_User_Defined_Binary_Op (N, Op_Id);
1123             end if;
1124
1125             Op_Id := Homonym (Op_Id);
1126          end loop;
1127
1128          if Etype (N) /= Any_Type then
1129             Op_Id := Entity (N);
1130
1131             Rewrite (N,
1132               Make_Op_Not (Loc,
1133                 Right_Opnd =>
1134                   Make_Op_Eq (Loc,
1135                     Left_Opnd =>  Relocate_Node (Left_Opnd (N)),
1136                     Right_Opnd => Relocate_Node (Right_Opnd (N)))));
1137
1138             Set_Entity (Right_Opnd (N), Op_Id);
1139             Analyze (N);
1140          end if;
1141       end if;
1142
1143       Operator_Check (N);
1144    end Analyze_Equality_Op;
1145
1146    ----------------------------------
1147    -- Analyze_Explicit_Dereference --
1148    ----------------------------------
1149
1150    procedure Analyze_Explicit_Dereference (N : Node_Id) is
1151       Loc   : constant Source_Ptr := Sloc (N);
1152       P     : constant Node_Id := Prefix (N);
1153       T     : Entity_Id;
1154       I     : Interp_Index;
1155       It    : Interp;
1156       New_N : Node_Id;
1157
1158       function Is_Function_Type return Boolean;
1159       --  Check whether node may be interpreted as an implicit function call
1160
1161       ----------------------
1162       -- Is_Function_Type --
1163       ----------------------
1164
1165       function Is_Function_Type return Boolean is
1166          I  : Interp_Index;
1167          It : Interp;
1168
1169       begin
1170          if not Is_Overloaded (N) then
1171             return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
1172               and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
1173
1174          else
1175             Get_First_Interp (N, I, It);
1176
1177             while Present (It.Nam) loop
1178                if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
1179                  or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
1180                then
1181                   return False;
1182                end if;
1183
1184                Get_Next_Interp (I, It);
1185             end loop;
1186
1187             return True;
1188          end if;
1189       end Is_Function_Type;
1190
1191    --  Start of processing for Analyze_Explicit_Deference
1192
1193    begin
1194       Analyze (P);
1195       Set_Etype (N, Any_Type);
1196
1197       --  Test for remote access to subprogram type, and if so return
1198       --  after rewriting the original tree.
1199
1200       if Remote_AST_E_Dereference (P) then
1201          return;
1202       end if;
1203
1204       --  Normal processing for other than remote access to subprogram type
1205
1206       if not Is_Overloaded (P) then
1207          if Is_Access_Type (Etype (P)) then
1208
1209             --  Set the Etype. We need to go thru Is_For_Access_Subtypes
1210             --  to avoid other problems caused by the Private_Subtype
1211             --  and it is safe to go to the Base_Type because this is the
1212             --  same as converting the access value to its Base_Type.
1213
1214             declare
1215                DT : Entity_Id := Designated_Type (Etype (P));
1216
1217             begin
1218                if Ekind (DT) = E_Private_Subtype
1219                  and then Is_For_Access_Subtype (DT)
1220                then
1221                   DT := Base_Type (DT);
1222                end if;
1223
1224                Set_Etype (N, DT);
1225             end;
1226
1227          elsif Etype (P) /= Any_Type then
1228             Error_Msg_N ("prefix of dereference must be an access type", N);
1229             return;
1230          end if;
1231
1232       else
1233          Get_First_Interp (P, I, It);
1234
1235          while Present (It.Nam) loop
1236             T := It.Typ;
1237
1238             if Is_Access_Type (T) then
1239                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
1240             end if;
1241
1242             Get_Next_Interp (I, It);
1243          end loop;
1244
1245          End_Interp_List;
1246
1247          --  Error if no interpretation of the prefix has an access type
1248
1249          if Etype (N) = Any_Type then
1250             Error_Msg_N
1251               ("access type required in prefix of explicit dereference", P);
1252             Set_Etype (N, Any_Type);
1253             return;
1254          end if;
1255       end if;
1256
1257       if Is_Function_Type
1258         and then Nkind (Parent (N)) /= N_Indexed_Component
1259
1260         and then (Nkind (Parent (N)) /= N_Function_Call
1261                    or else N /= Name (Parent (N)))
1262
1263         and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
1264                    or else N /= Name (Parent (N)))
1265
1266         and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
1267         and then (Nkind (Parent (N)) /= N_Attribute_Reference
1268                     or else
1269                       (Attribute_Name (Parent (N)) /= Name_Address
1270                         and then
1271                        Attribute_Name (Parent (N)) /= Name_Access))
1272       then
1273          --  Name is a function call with no actuals, in a context that
1274          --  requires deproceduring (including as an actual in an enclosing
1275          --  function or procedure call). We can conceive of pathological cases
1276          --  where the prefix might include functions that return access to
1277          --  subprograms and others that return a regular type. Disambiguation
1278          --  of those will have to take place in Resolve. See e.g. 7117-014.
1279
1280          New_N :=
1281            Make_Function_Call (Loc,
1282            Name => Make_Explicit_Dereference (Loc, P),
1283            Parameter_Associations => New_List);
1284
1285          --  If the prefix is overloaded, remove operations that have formals,
1286          --  we know that this is a parameterless call.
1287
1288          if Is_Overloaded (P) then
1289             Get_First_Interp (P, I, It);
1290             while Present (It.Nam) loop
1291                T := It.Typ;
1292
1293                if No (First_Formal (Base_Type (Designated_Type (T)))) then
1294                   Set_Etype (P, T);
1295                else
1296                   Remove_Interp (I);
1297                end if;
1298
1299                Get_Next_Interp (I, It);
1300             end loop;
1301          end if;
1302
1303          Rewrite (N, New_N);
1304          Analyze (N);
1305       end if;
1306
1307       --  A value of remote access-to-class-wide must not be dereferenced
1308       --  (RM E.2.2(16)).
1309
1310       Validate_Remote_Access_To_Class_Wide_Type (N);
1311    end Analyze_Explicit_Dereference;
1312
1313    ------------------------
1314    -- Analyze_Expression --
1315    ------------------------
1316
1317    procedure Analyze_Expression (N : Node_Id) is
1318    begin
1319       Analyze (N);
1320       Check_Parameterless_Call (N);
1321    end Analyze_Expression;
1322
1323    ------------------------------------
1324    -- Analyze_Indexed_Component_Form --
1325    ------------------------------------
1326
1327    procedure Analyze_Indexed_Component_Form (N : Node_Id) is
1328       P     : constant Node_Id := Prefix (N);
1329       Exprs : constant List_Id := Expressions (N);
1330       Exp   : Node_Id;
1331       P_T   : Entity_Id;
1332       E     : Node_Id;
1333       U_N   : Entity_Id;
1334
1335       procedure Process_Function_Call;
1336       --  Prefix in indexed component form is an overloadable entity,
1337       --  so the node is a function call. Reformat it as such.
1338
1339       procedure Process_Indexed_Component;
1340       --  Prefix in indexed component form is actually an indexed component.
1341       --  This routine processes it, knowing that the prefix is already
1342       --  resolved.
1343
1344       procedure Process_Indexed_Component_Or_Slice;
1345       --  An indexed component with a single index may designate a slice if
1346       --  the index is a subtype mark. This routine disambiguates these two
1347       --  cases by resolving the prefix to see if it is a subtype mark.
1348
1349       procedure Process_Overloaded_Indexed_Component;
1350       --  If the prefix of an indexed component is overloaded, the proper
1351       --  interpretation is selected by the index types and the context.
1352
1353       ---------------------------
1354       -- Process_Function_Call --
1355       ---------------------------
1356
1357       procedure Process_Function_Call is
1358          Actual : Node_Id;
1359
1360       begin
1361          Change_Node (N, N_Function_Call);
1362          Set_Name (N, P);
1363          Set_Parameter_Associations (N, Exprs);
1364
1365          Actual := First (Parameter_Associations (N));
1366          while Present (Actual) loop
1367             Analyze (Actual);
1368             Check_Parameterless_Call (Actual);
1369             Next_Actual (Actual);
1370          end loop;
1371
1372          Analyze_Call (N);
1373       end Process_Function_Call;
1374
1375       -------------------------------
1376       -- Process_Indexed_Component --
1377       -------------------------------
1378
1379       procedure Process_Indexed_Component is
1380          Exp          : Node_Id;
1381          Array_Type   : Entity_Id;
1382          Index        : Node_Id;
1383          Pent         : Entity_Id := Empty;
1384
1385       begin
1386          Exp := First (Exprs);
1387
1388          if Is_Overloaded (P) then
1389             Process_Overloaded_Indexed_Component;
1390
1391          else
1392             Array_Type := Etype (P);
1393
1394             if Is_Entity_Name (P) then
1395                Pent := Entity (P);
1396             elsif Nkind (P) = N_Selected_Component
1397               and then Is_Entity_Name (Selector_Name (P))
1398             then
1399                Pent := Entity (Selector_Name (P));
1400             end if;
1401
1402             --  Prefix must be appropriate for an array type, taking into
1403             --  account a possible implicit dereference.
1404
1405             if Is_Access_Type (Array_Type) then
1406                Array_Type := Designated_Type (Array_Type);
1407                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1408                Process_Implicit_Dereference_Prefix (Pent, P);
1409             end if;
1410
1411             if Is_Array_Type (Array_Type) then
1412                null;
1413
1414             elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
1415                Analyze (Exp);
1416                Set_Etype (N, Any_Type);
1417
1418                if not Has_Compatible_Type
1419                  (Exp, Entry_Index_Type (Pent))
1420                then
1421                   Error_Msg_N ("invalid index type in entry name", N);
1422
1423                elsif Present (Next (Exp)) then
1424                   Error_Msg_N ("too many subscripts in entry reference", N);
1425
1426                else
1427                   Set_Etype (N,  Etype (P));
1428                end if;
1429
1430                return;
1431
1432             elsif Is_Record_Type (Array_Type)
1433               and then Remote_AST_I_Dereference (P)
1434             then
1435                return;
1436
1437             elsif Array_Type = Any_Type then
1438                Set_Etype (N, Any_Type);
1439                return;
1440
1441             --  Here we definitely have a bad indexing
1442
1443             else
1444                if Nkind (Parent (N)) = N_Requeue_Statement
1445                  and then Present (Pent) and then Ekind (Pent) = E_Entry
1446                then
1447                   Error_Msg_N
1448                     ("REQUEUE does not permit parameters", First (Exprs));
1449
1450                elsif Is_Entity_Name (P)
1451                  and then Etype (P) = Standard_Void_Type
1452                then
1453                   Error_Msg_NE ("incorrect use of&", P, Entity (P));
1454
1455                else
1456                   Error_Msg_N ("array type required in indexed component", P);
1457                end if;
1458
1459                Set_Etype (N, Any_Type);
1460                return;
1461             end if;
1462
1463             Index := First_Index (Array_Type);
1464
1465             while Present (Index) and then Present (Exp) loop
1466                if not Has_Compatible_Type (Exp, Etype (Index)) then
1467                   Wrong_Type (Exp, Etype (Index));
1468                   Set_Etype (N, Any_Type);
1469                   return;
1470                end if;
1471
1472                Next_Index (Index);
1473                Next (Exp);
1474             end loop;
1475
1476             Set_Etype (N, Component_Type (Array_Type));
1477
1478             if Present (Index) then
1479                Error_Msg_N
1480                  ("too few subscripts in array reference", First (Exprs));
1481
1482             elsif Present (Exp) then
1483                Error_Msg_N ("too many subscripts in array reference", Exp);
1484             end if;
1485          end if;
1486       end Process_Indexed_Component;
1487
1488       ----------------------------------------
1489       -- Process_Indexed_Component_Or_Slice --
1490       ----------------------------------------
1491
1492       procedure Process_Indexed_Component_Or_Slice is
1493       begin
1494          Exp := First (Exprs);
1495          while Present (Exp) loop
1496             Analyze_Expression (Exp);
1497             Next (Exp);
1498          end loop;
1499
1500          Exp := First (Exprs);
1501
1502          --  If one index is present, and it is a subtype name, then the
1503          --  node denotes a slice (note that the case of an explicit range
1504          --  for a slice was already built as an N_Slice node in the first
1505          --  place, so that case is not handled here).
1506
1507          --  We use a replace rather than a rewrite here because this is one
1508          --  of the cases in which the tree built by the parser is plain wrong.
1509
1510          if No (Next (Exp))
1511            and then Is_Entity_Name (Exp)
1512            and then Is_Type (Entity (Exp))
1513          then
1514             Replace (N,
1515                Make_Slice (Sloc (N),
1516                  Prefix => P,
1517                  Discrete_Range => New_Copy (Exp)));
1518             Analyze (N);
1519
1520          --  Otherwise (more than one index present, or single index is not
1521          --  a subtype name), then we have the indexed component case.
1522
1523          else
1524             Process_Indexed_Component;
1525          end if;
1526       end Process_Indexed_Component_Or_Slice;
1527
1528       ------------------------------------------
1529       -- Process_Overloaded_Indexed_Component --
1530       ------------------------------------------
1531
1532       procedure Process_Overloaded_Indexed_Component is
1533          Exp   : Node_Id;
1534          I     : Interp_Index;
1535          It    : Interp;
1536          Typ   : Entity_Id;
1537          Index : Node_Id;
1538          Found : Boolean;
1539
1540       begin
1541          Set_Etype (N, Any_Type);
1542
1543          Get_First_Interp (P, I, It);
1544          while Present (It.Nam) loop
1545             Typ := It.Typ;
1546
1547             if Is_Access_Type (Typ) then
1548                Typ := Designated_Type (Typ);
1549                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1550             end if;
1551
1552             if Is_Array_Type (Typ) then
1553
1554                --  Got a candidate: verify that index types are compatible
1555
1556                Index := First_Index (Typ);
1557                Found := True;
1558                Exp := First (Exprs);
1559                while Present (Index) and then Present (Exp) loop
1560                   if Has_Compatible_Type (Exp, Etype (Index)) then
1561                      null;
1562                   else
1563                      Found := False;
1564                      Remove_Interp (I);
1565                      exit;
1566                   end if;
1567
1568                   Next_Index (Index);
1569                   Next (Exp);
1570                end loop;
1571
1572                if Found and then No (Index) and then No (Exp) then
1573                   Add_One_Interp (N,
1574                      Etype (Component_Type (Typ)),
1575                      Etype (Component_Type (Typ)));
1576                end if;
1577             end if;
1578
1579             Get_Next_Interp (I, It);
1580          end loop;
1581
1582          if Etype (N) = Any_Type then
1583             Error_Msg_N ("no legal interpetation for indexed component", N);
1584             Set_Is_Overloaded (N, False);
1585          end if;
1586
1587          End_Interp_List;
1588       end Process_Overloaded_Indexed_Component;
1589
1590    --  Start of processing for Analyze_Indexed_Component_Form
1591
1592    begin
1593       --  Get name of array, function or type
1594
1595       Analyze (P);
1596       if Nkind (N) = N_Function_Call
1597         or else Nkind (N) = N_Procedure_Call_Statement
1598       then
1599          --  If P is an explicit dereference whose prefix is of a
1600          --  remote access-to-subprogram type, then N has already
1601          --  been rewritten as a subprogram call and analyzed.
1602
1603          return;
1604       end if;
1605
1606       pragma Assert (Nkind (N) = N_Indexed_Component);
1607
1608       P_T := Base_Type (Etype (P));
1609
1610       if Is_Entity_Name (P)
1611         or else Nkind (P) = N_Operator_Symbol
1612       then
1613          U_N := Entity (P);
1614
1615          if Ekind (U_N) in Type_Kind then
1616
1617             --  Reformat node as a type conversion
1618
1619             E := Remove_Head (Exprs);
1620
1621             if Present (First (Exprs)) then
1622                Error_Msg_N
1623                 ("argument of type conversion must be single expression", N);
1624             end if;
1625
1626             Change_Node (N, N_Type_Conversion);
1627             Set_Subtype_Mark (N, P);
1628             Set_Etype (N, U_N);
1629             Set_Expression (N, E);
1630
1631             --  After changing the node, call for the specific Analysis
1632             --  routine directly, to avoid a double call to the expander.
1633
1634             Analyze_Type_Conversion (N);
1635             return;
1636          end if;
1637
1638          if Is_Overloadable (U_N) then
1639             Process_Function_Call;
1640
1641          elsif Ekind (Etype (P)) = E_Subprogram_Type
1642            or else (Is_Access_Type (Etype (P))
1643                       and then
1644                     Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
1645          then
1646             --  Call to access_to-subprogram with possible implicit dereference
1647
1648             Process_Function_Call;
1649
1650          elsif Is_Generic_Subprogram (U_N) then
1651
1652             --  A common beginner's (or C++ templates fan) error
1653
1654             Error_Msg_N ("generic subprogram cannot be called", N);
1655             Set_Etype (N, Any_Type);
1656             return;
1657
1658          else
1659             Process_Indexed_Component_Or_Slice;
1660          end if;
1661
1662       --  If not an entity name, prefix is an expression that may denote
1663       --  an array or an access-to-subprogram.
1664
1665       else
1666          if Ekind (P_T) = E_Subprogram_Type
1667            or else (Is_Access_Type (P_T)
1668                      and then
1669                     Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
1670          then
1671             Process_Function_Call;
1672
1673          elsif Nkind (P) = N_Selected_Component
1674            and then Is_Overloadable (Entity (Selector_Name (P)))
1675          then
1676             Process_Function_Call;
1677
1678          else
1679             --  Indexed component, slice, or a call to a member of a family
1680             --  entry, which will be converted to an entry call later.
1681
1682             Process_Indexed_Component_Or_Slice;
1683          end if;
1684       end if;
1685    end Analyze_Indexed_Component_Form;
1686
1687    ------------------------
1688    -- Analyze_Logical_Op --
1689    ------------------------
1690
1691    procedure Analyze_Logical_Op (N : Node_Id) is
1692       L     : constant Node_Id := Left_Opnd (N);
1693       R     : constant Node_Id := Right_Opnd (N);
1694       Op_Id : Entity_Id := Entity (N);
1695
1696    begin
1697       Set_Etype (N, Any_Type);
1698       Candidate_Type := Empty;
1699
1700       Analyze_Expression (L);
1701       Analyze_Expression (R);
1702
1703       if Present (Op_Id) then
1704
1705          if Ekind (Op_Id) = E_Operator then
1706             Find_Boolean_Types (L, R, Op_Id, N);
1707          else
1708             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1709          end if;
1710
1711       else
1712          Op_Id := Get_Name_Entity_Id (Chars (N));
1713
1714          while Present (Op_Id) loop
1715             if Ekind (Op_Id) = E_Operator then
1716                Find_Boolean_Types (L, R, Op_Id, N);
1717             else
1718                Analyze_User_Defined_Binary_Op (N, Op_Id);
1719             end if;
1720
1721             Op_Id := Homonym (Op_Id);
1722          end loop;
1723       end if;
1724
1725       Operator_Check (N);
1726    end Analyze_Logical_Op;
1727
1728    ---------------------------
1729    -- Analyze_Membership_Op --
1730    ---------------------------
1731
1732    procedure Analyze_Membership_Op (N : Node_Id) is
1733       L     : constant Node_Id := Left_Opnd (N);
1734       R     : constant Node_Id := Right_Opnd (N);
1735
1736       Index : Interp_Index;
1737       It    : Interp;
1738       Found : Boolean := False;
1739       I_F   : Interp_Index;
1740       T_F   : Entity_Id;
1741
1742       procedure Try_One_Interp (T1 : Entity_Id);
1743       --  Routine to try one proposed interpretation. Note that the context
1744       --  of the operation plays no role in resolving the arguments, so that
1745       --  if there is more than one interpretation of the operands that is
1746       --  compatible with a membership test, the operation is ambiguous.
1747
1748       --------------------
1749       -- Try_One_Interp --
1750       --------------------
1751
1752       procedure Try_One_Interp (T1 : Entity_Id) is
1753       begin
1754          if Has_Compatible_Type (R, T1) then
1755             if Found
1756               and then Base_Type (T1) /= Base_Type (T_F)
1757             then
1758                It := Disambiguate (L, I_F, Index, Any_Type);
1759
1760                if It = No_Interp then
1761                   Ambiguous_Operands (N);
1762                   Set_Etype (L, Any_Type);
1763                   return;
1764
1765                else
1766                   T_F := It.Typ;
1767                end if;
1768
1769             else
1770                Found := True;
1771                T_F   := T1;
1772                I_F   := Index;
1773             end if;
1774
1775             Set_Etype (L, T_F);
1776          end if;
1777
1778       end Try_One_Interp;
1779
1780    --  Start of processing for Analyze_Membership_Op
1781
1782    begin
1783       Analyze_Expression (L);
1784
1785       if Nkind (R) = N_Range
1786         or else (Nkind (R) = N_Attribute_Reference
1787                   and then Attribute_Name (R) = Name_Range)
1788       then
1789          Analyze (R);
1790
1791          if not Is_Overloaded (L) then
1792             Try_One_Interp (Etype (L));
1793
1794          else
1795             Get_First_Interp (L, Index, It);
1796
1797             while Present (It.Typ) loop
1798                Try_One_Interp (It.Typ);
1799                Get_Next_Interp (Index, It);
1800             end loop;
1801          end if;
1802
1803       --  If not a range, it can only be a subtype mark, or else there
1804       --  is a more basic error, to be diagnosed in Find_Type.
1805
1806       else
1807          Find_Type (R);
1808
1809          if Is_Entity_Name (R) then
1810             Check_Fully_Declared (Entity (R), R);
1811          end if;
1812       end if;
1813
1814       --  Compatibility between expression and subtype mark or range is
1815       --  checked during resolution. The result of the operation is Boolean
1816       --  in any case.
1817
1818       Set_Etype (N, Standard_Boolean);
1819    end Analyze_Membership_Op;
1820
1821    ----------------------
1822    -- Analyze_Negation --
1823    ----------------------
1824
1825    procedure Analyze_Negation (N : Node_Id) is
1826       R     : constant Node_Id := Right_Opnd (N);
1827       Op_Id : Entity_Id := Entity (N);
1828
1829    begin
1830       Set_Etype (N, Any_Type);
1831       Candidate_Type := Empty;
1832
1833       Analyze_Expression (R);
1834
1835       if Present (Op_Id) then
1836          if Ekind (Op_Id) = E_Operator then
1837             Find_Negation_Types (R, Op_Id, N);
1838          else
1839             Add_One_Interp (N, Op_Id, Etype (Op_Id));
1840          end if;
1841
1842       else
1843          Op_Id := Get_Name_Entity_Id (Chars (N));
1844          while Present (Op_Id) loop
1845             if Ekind (Op_Id) = E_Operator then
1846                Find_Negation_Types (R, Op_Id, N);
1847             else
1848                Analyze_User_Defined_Unary_Op (N, Op_Id);
1849             end if;
1850
1851             Op_Id := Homonym (Op_Id);
1852          end loop;
1853       end if;
1854
1855       Operator_Check (N);
1856    end Analyze_Negation;
1857
1858    ------------------
1859    -- Analyze_Null --
1860    ------------------
1861
1862    procedure Analyze_Null (N : Node_Id) is
1863    begin
1864       Set_Etype (N, Any_Access);
1865    end Analyze_Null;
1866
1867    ----------------------
1868    -- Analyze_One_Call --
1869    ----------------------
1870
1871    procedure Analyze_One_Call
1872       (N       : Node_Id;
1873        Nam     : Entity_Id;
1874        Report  : Boolean;
1875        Success : out Boolean)
1876    is
1877       Actuals    : constant List_Id   := Parameter_Associations (N);
1878       Prev_T     : constant Entity_Id := Etype (N);
1879       Formal     : Entity_Id;
1880       Actual     : Node_Id;
1881       Is_Indexed : Boolean := False;
1882       Subp_Type  : constant Entity_Id := Etype (Nam);
1883       Norm_OK    : Boolean;
1884
1885       procedure Indicate_Name_And_Type;
1886       --  If candidate interpretation matches, indicate name and type of
1887       --  result on call node.
1888
1889       ----------------------------
1890       -- Indicate_Name_And_Type --
1891       ----------------------------
1892
1893       procedure Indicate_Name_And_Type is
1894       begin
1895          Add_One_Interp (N, Nam, Etype (Nam));
1896          Success := True;
1897
1898          --  If the prefix of the call is a name, indicate the entity
1899          --  being called. If it is not a name,  it is an expression that
1900          --  denotes an access to subprogram or else an entry or family. In
1901          --  the latter case, the name is a selected component, and the entity
1902          --  being called is noted on the selector.
1903
1904          if not Is_Type (Nam) then
1905             if Is_Entity_Name (Name (N))
1906               or else Nkind (Name (N)) = N_Operator_Symbol
1907             then
1908                Set_Entity (Name (N), Nam);
1909
1910             elsif Nkind (Name (N)) = N_Selected_Component then
1911                Set_Entity (Selector_Name (Name (N)),  Nam);
1912             end if;
1913          end if;
1914
1915          if Debug_Flag_E and not Report then
1916             Write_Str (" Overloaded call ");
1917             Write_Int (Int (N));
1918             Write_Str (" compatible with ");
1919             Write_Int (Int (Nam));
1920             Write_Eol;
1921          end if;
1922       end Indicate_Name_And_Type;
1923
1924    --  Start of processing for Analyze_One_Call
1925
1926    begin
1927       Success := False;
1928
1929       --  If the subprogram has no formals, or if all the formals have
1930       --  defaults, and the return type is an array type, the node may
1931       --  denote an indexing of the result of a parameterless call.
1932
1933       if Needs_No_Actuals (Nam)
1934         and then Present (Actuals)
1935       then
1936          if Is_Array_Type (Subp_Type) then
1937             Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type);
1938
1939          elsif Is_Access_Type (Subp_Type)
1940            and then Is_Array_Type (Designated_Type (Subp_Type))
1941          then
1942             Is_Indexed :=
1943               Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type));
1944
1945          elsif Is_Access_Type (Subp_Type)
1946            and then Ekind (Designated_Type (Subp_Type))  = E_Subprogram_Type
1947          then
1948             Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
1949          end if;
1950
1951       end if;
1952
1953       Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
1954
1955       if not Norm_OK then
1956
1957          --  Mismatch in number or names of parameters
1958
1959          if Debug_Flag_E then
1960             Write_Str (" normalization fails in call ");
1961             Write_Int (Int (N));
1962             Write_Str (" with subprogram ");
1963             Write_Int (Int (Nam));
1964             Write_Eol;
1965          end if;
1966
1967       --  If the context expects a function call, discard any interpretation
1968       --  that is a procedure. If the node is not overloaded, leave as is for
1969       --  better error reporting when type mismatch is found.
1970
1971       elsif Nkind (N) = N_Function_Call
1972         and then Is_Overloaded (Name (N))
1973         and then Ekind (Nam) = E_Procedure
1974       then
1975          return;
1976
1977       --  Ditto for function calls in a procedure context
1978
1979       elsif Nkind (N) = N_Procedure_Call_Statement
1980          and then Is_Overloaded (Name (N))
1981          and then Etype (Nam) /= Standard_Void_Type
1982       then
1983          return;
1984
1985       elsif not Present (Actuals) then
1986
1987          --  If Normalize succeeds, then there are default parameters for
1988          --  all formals.
1989
1990          Indicate_Name_And_Type;
1991
1992       elsif Ekind (Nam) = E_Operator then
1993          if Nkind (N) = N_Procedure_Call_Statement then
1994             return;
1995          end if;
1996
1997          --  This can occur when the prefix of the call is an operator
1998          --  name or an expanded name whose selector is an operator name.
1999
2000          Analyze_Operator_Call (N, Nam);
2001
2002          if Etype (N) /= Prev_T then
2003
2004             --  There may be a user-defined operator that hides the
2005             --  current interpretation. We must check for this independently
2006             --  of the analysis of the call with the user-defined operation,
2007             --  because the parameter names may be wrong and yet the hiding
2008             --  takes place. Fixes b34014o.
2009
2010             if Is_Overloaded (Name (N)) then
2011                declare
2012                   I  : Interp_Index;
2013                   It : Interp;
2014
2015                begin
2016                   Get_First_Interp (Name (N), I, It);
2017                   while Present (It.Nam) loop
2018                      if Ekind (It.Nam) /= E_Operator
2019                         and then Hides_Op (It.Nam, Nam)
2020                         and then
2021                           Has_Compatible_Type
2022                             (First_Actual (N), Etype (First_Formal (It.Nam)))
2023                         and then (No (Next_Actual (First_Actual (N)))
2024                            or else Has_Compatible_Type
2025                             (Next_Actual (First_Actual (N)),
2026                              Etype (Next_Formal (First_Formal (It.Nam)))))
2027                      then
2028                         Set_Etype (N, Prev_T);
2029                         return;
2030                      end if;
2031
2032                      Get_Next_Interp (I, It);
2033                   end loop;
2034                end;
2035             end if;
2036
2037             --  If operator matches formals, record its name on the call.
2038             --  If the operator is overloaded, Resolve will select the
2039             --  correct one from the list of interpretations. The call
2040             --  node itself carries the first candidate.
2041
2042             Set_Entity (Name (N), Nam);
2043             Success := True;
2044
2045          elsif Report and then Etype (N) = Any_Type then
2046             Error_Msg_N ("incompatible arguments for operator", N);
2047          end if;
2048
2049       else
2050          --  Normalize_Actuals has chained the named associations in the
2051          --  correct order of the formals.
2052
2053          Actual := First_Actual (N);
2054          Formal := First_Formal (Nam);
2055          while Present (Actual) and then Present (Formal) loop
2056             if Nkind (Parent (Actual)) /= N_Parameter_Association
2057               or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
2058             then
2059                if Has_Compatible_Type (Actual, Etype (Formal)) then
2060                   Next_Actual (Actual);
2061                   Next_Formal (Formal);
2062
2063                else
2064                   if Debug_Flag_E then
2065                      Write_Str (" type checking fails in call ");
2066                      Write_Int (Int (N));
2067                      Write_Str (" with formal ");
2068                      Write_Int (Int (Formal));
2069                      Write_Str (" in subprogram ");
2070                      Write_Int (Int (Nam));
2071                      Write_Eol;
2072                   end if;
2073
2074                   if Report and not Is_Indexed then
2075                      Wrong_Type (Actual, Etype (Formal));
2076
2077                      if Nkind (Actual) = N_Op_Eq
2078                        and then Nkind (Left_Opnd (Actual)) = N_Identifier
2079                      then
2080                         Formal := First_Formal (Nam);
2081
2082                         while Present (Formal) loop
2083
2084                            if Chars (Left_Opnd (Actual)) = Chars (Formal) then
2085                               Error_Msg_N
2086                                 ("possible misspelling of `='>`!", Actual);
2087                               exit;
2088                            end if;
2089
2090                            Next_Formal (Formal);
2091                         end loop;
2092                      end if;
2093
2094                      if All_Errors_Mode then
2095                         Error_Msg_Sloc := Sloc (Nam);
2096
2097                         if Is_Overloadable (Nam)
2098                           and then Present (Alias (Nam))
2099                           and then not Comes_From_Source (Nam)
2100                         then
2101                            Error_Msg_NE
2102                              ("  =='> in call to &#(inherited)!", Actual, Nam);
2103
2104                         elsif Ekind (Nam) = E_Subprogram_Type then
2105                            declare
2106                               Access_To_Subprogram_Typ :
2107                                 constant Entity_Id :=
2108                                   Defining_Identifier
2109                                     (Associated_Node_For_Itype (Nam));
2110                            begin
2111                               Error_Msg_NE (
2112                                 "  =='> in call to dereference of &#!",
2113                                 Actual, Access_To_Subprogram_Typ);
2114                            end;
2115
2116                         else
2117                            Error_Msg_NE ("  =='> in call to &#!", Actual, Nam);
2118
2119                         end if;
2120                      end if;
2121                   end if;
2122
2123                   return;
2124                end if;
2125
2126             else
2127                --  Normalize_Actuals has verified that a default value exists
2128                --  for this formal. Current actual names a subsequent formal.
2129
2130                Next_Formal (Formal);
2131             end if;
2132          end loop;
2133
2134          --  On exit, all actuals match
2135
2136          Indicate_Name_And_Type;
2137       end if;
2138    end Analyze_One_Call;
2139
2140    ---------------------------
2141    -- Analyze_Operator_Call --
2142    ---------------------------
2143
2144    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
2145       Op_Name : constant Name_Id := Chars (Op_Id);
2146       Act1    : constant Node_Id := First_Actual (N);
2147       Act2    : constant Node_Id := Next_Actual (Act1);
2148
2149    begin
2150       --  Binary operator case
2151
2152       if Present (Act2) then
2153
2154          --  If more than two operands, then not binary operator after all
2155
2156          if Present (Next_Actual (Act2)) then
2157             return;
2158
2159          elsif     Op_Name = Name_Op_Add
2160            or else Op_Name = Name_Op_Subtract
2161            or else Op_Name = Name_Op_Multiply
2162            or else Op_Name = Name_Op_Divide
2163            or else Op_Name = Name_Op_Mod
2164            or else Op_Name = Name_Op_Rem
2165            or else Op_Name = Name_Op_Expon
2166          then
2167             Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
2168
2169          elsif     Op_Name =  Name_Op_And
2170            or else Op_Name = Name_Op_Or
2171            or else Op_Name = Name_Op_Xor
2172          then
2173             Find_Boolean_Types (Act1, Act2, Op_Id, N);
2174
2175          elsif     Op_Name = Name_Op_Lt
2176            or else Op_Name = Name_Op_Le
2177            or else Op_Name = Name_Op_Gt
2178            or else Op_Name = Name_Op_Ge
2179          then
2180             Find_Comparison_Types (Act1, Act2, Op_Id,  N);
2181
2182          elsif     Op_Name = Name_Op_Eq
2183            or else Op_Name = Name_Op_Ne
2184          then
2185             Find_Equality_Types (Act1, Act2, Op_Id,  N);
2186
2187          elsif     Op_Name = Name_Op_Concat then
2188             Find_Concatenation_Types (Act1, Act2, Op_Id, N);
2189
2190          --  Is this else null correct, or should it be an abort???
2191
2192          else
2193             null;
2194          end if;
2195
2196       --  Unary operator case
2197
2198       else
2199          if Op_Name = Name_Op_Subtract or else
2200             Op_Name = Name_Op_Add      or else
2201             Op_Name = Name_Op_Abs
2202          then
2203             Find_Unary_Types (Act1, Op_Id, N);
2204
2205          elsif
2206             Op_Name = Name_Op_Not
2207          then
2208             Find_Negation_Types (Act1, Op_Id, N);
2209
2210          --  Is this else null correct, or should it be an abort???
2211
2212          else
2213             null;
2214          end if;
2215       end if;
2216    end Analyze_Operator_Call;
2217
2218    -------------------------------------------
2219    -- Analyze_Overloaded_Selected_Component --
2220    -------------------------------------------
2221
2222    procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
2223       Nam   : constant Node_Id := Prefix (N);
2224       Sel   : constant Node_Id := Selector_Name (N);
2225       Comp  : Entity_Id;
2226       I     : Interp_Index;
2227       It    : Interp;
2228       T     : Entity_Id;
2229
2230    begin
2231       Set_Etype (Sel, Any_Type);
2232
2233       Get_First_Interp (Nam, I, It);
2234       while Present (It.Typ) loop
2235          if Is_Access_Type (It.Typ) then
2236             T := Designated_Type (It.Typ);
2237             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2238          else
2239             T := It.Typ;
2240          end if;
2241
2242          if Is_Record_Type (T) then
2243             Comp := First_Entity (T);
2244             while Present (Comp) loop
2245                if Chars (Comp) = Chars (Sel)
2246                  and then Is_Visible_Component (Comp)
2247                then
2248                   Set_Entity_With_Style_Check (Sel, Comp);
2249                   Generate_Reference (Comp, Sel);
2250
2251                   Set_Etype (Sel, Etype (Comp));
2252                   Add_One_Interp (N, Etype (Comp), Etype (Comp));
2253
2254                   --  This also specifies a candidate to resolve the name.
2255                   --  Further overloading will be resolved from context.
2256
2257                   Set_Etype (Nam, It.Typ);
2258                end if;
2259
2260                Next_Entity (Comp);
2261             end loop;
2262
2263          elsif Is_Concurrent_Type (T) then
2264             Comp := First_Entity (T);
2265             while Present (Comp)
2266               and then Comp /= First_Private_Entity (T)
2267             loop
2268                if Chars (Comp) = Chars (Sel) then
2269                   if Is_Overloadable (Comp) then
2270                      Add_One_Interp (Sel, Comp, Etype (Comp));
2271                   else
2272                      Set_Entity_With_Style_Check (Sel, Comp);
2273                      Generate_Reference (Comp, Sel);
2274                   end if;
2275
2276                   Set_Etype (Sel, Etype (Comp));
2277                   Set_Etype (N,   Etype (Comp));
2278                   Set_Etype (Nam, It.Typ);
2279
2280                   --  For access type case, introduce explicit deference for
2281                   --  more uniform treatment of entry calls.
2282
2283                   if Is_Access_Type (Etype (Nam)) then
2284                      Insert_Explicit_Dereference (Nam);
2285                      Error_Msg_NW
2286                        (Warn_On_Dereference, "?implicit dereference", N);
2287                   end if;
2288                end if;
2289
2290                Next_Entity (Comp);
2291             end loop;
2292
2293             Set_Is_Overloaded (N, Is_Overloaded (Sel));
2294          end if;
2295
2296          Get_Next_Interp (I, It);
2297       end loop;
2298
2299       if Etype (N) = Any_Type then
2300          Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
2301          Set_Entity (Sel, Any_Id);
2302          Set_Etype  (Sel, Any_Type);
2303       end if;
2304    end Analyze_Overloaded_Selected_Component;
2305
2306    ----------------------------------
2307    -- Analyze_Qualified_Expression --
2308    ----------------------------------
2309
2310    procedure Analyze_Qualified_Expression (N : Node_Id) is
2311       Mark : constant Entity_Id := Subtype_Mark (N);
2312       T    : Entity_Id;
2313
2314    begin
2315       Set_Etype (N, Any_Type);
2316       Find_Type (Mark);
2317       T := Entity (Mark);
2318
2319       if T = Any_Type then
2320          return;
2321       end if;
2322
2323       Check_Fully_Declared (T, N);
2324       Analyze_Expression (Expression (N));
2325       Set_Etype  (N, T);
2326    end Analyze_Qualified_Expression;
2327
2328    -------------------
2329    -- Analyze_Range --
2330    -------------------
2331
2332    procedure Analyze_Range (N : Node_Id) is
2333       L        : constant Node_Id := Low_Bound (N);
2334       H        : constant Node_Id := High_Bound (N);
2335       I1, I2   : Interp_Index;
2336       It1, It2 : Interp;
2337
2338       procedure Check_Common_Type (T1, T2 : Entity_Id);
2339       --  Verify the compatibility of two types,  and choose the
2340       --  non universal one if the other is universal.
2341
2342       procedure Check_High_Bound (T : Entity_Id);
2343       --  Test one interpretation of the low bound against all those
2344       --  of the high bound.
2345
2346       procedure Check_Universal_Expression (N : Node_Id);
2347       --  In Ada83, reject bounds of a universal range that are not
2348       --  literals or entity names.
2349
2350       -----------------------
2351       -- Check_Common_Type --
2352       -----------------------
2353
2354       procedure Check_Common_Type (T1, T2 : Entity_Id) is
2355       begin
2356          if Covers (T1, T2) or else Covers (T2, T1) then
2357             if T1 = Universal_Integer
2358               or else T1 = Universal_Real
2359               or else T1 = Any_Character
2360             then
2361                Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
2362
2363             elsif T1 = T2 then
2364                Add_One_Interp (N, T1, T1);
2365
2366             else
2367                Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
2368             end if;
2369          end if;
2370       end Check_Common_Type;
2371
2372       ----------------------
2373       -- Check_High_Bound --
2374       ----------------------
2375
2376       procedure Check_High_Bound (T : Entity_Id) is
2377       begin
2378          if not Is_Overloaded (H) then
2379             Check_Common_Type (T, Etype (H));
2380          else
2381             Get_First_Interp (H, I2, It2);
2382             while Present (It2.Typ) loop
2383                Check_Common_Type (T, It2.Typ);
2384                Get_Next_Interp (I2, It2);
2385             end loop;
2386          end if;
2387       end Check_High_Bound;
2388
2389       -----------------------------
2390       -- Is_Universal_Expression --
2391       -----------------------------
2392
2393       procedure Check_Universal_Expression (N : Node_Id) is
2394       begin
2395          if Etype (N) = Universal_Integer
2396            and then Nkind (N) /= N_Integer_Literal
2397            and then not Is_Entity_Name (N)
2398            and then Nkind (N) /= N_Attribute_Reference
2399          then
2400             Error_Msg_N ("illegal bound in discrete range", N);
2401          end if;
2402       end Check_Universal_Expression;
2403
2404    --  Start of processing for Analyze_Range
2405
2406    begin
2407       Set_Etype (N, Any_Type);
2408       Analyze_Expression (L);
2409       Analyze_Expression (H);
2410
2411       if Etype (L) = Any_Type or else Etype (H) = Any_Type then
2412          return;
2413
2414       else
2415          if not Is_Overloaded (L) then
2416             Check_High_Bound (Etype (L));
2417          else
2418             Get_First_Interp (L, I1, It1);
2419             while Present (It1.Typ) loop
2420                Check_High_Bound (It1.Typ);
2421                Get_Next_Interp (I1, It1);
2422             end loop;
2423          end if;
2424
2425          --  If result is Any_Type, then we did not find a compatible pair
2426
2427          if Etype (N) = Any_Type then
2428             Error_Msg_N ("incompatible types in range ", N);
2429          end if;
2430       end if;
2431
2432       if Ada_Version = Ada_83
2433         and then
2434           (Nkind (Parent (N)) = N_Loop_Parameter_Specification
2435              or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
2436       then
2437          Check_Universal_Expression (L);
2438          Check_Universal_Expression (H);
2439       end if;
2440    end Analyze_Range;
2441
2442    -----------------------
2443    -- Analyze_Reference --
2444    -----------------------
2445
2446    procedure Analyze_Reference (N : Node_Id) is
2447       P        : constant Node_Id := Prefix (N);
2448       Acc_Type : Entity_Id;
2449    begin
2450       Analyze (P);
2451       Acc_Type := Create_Itype (E_Allocator_Type, N);
2452       Set_Etype                    (Acc_Type,  Acc_Type);
2453       Init_Size_Align              (Acc_Type);
2454       Set_Directly_Designated_Type (Acc_Type, Etype (P));
2455       Set_Etype (N, Acc_Type);
2456    end Analyze_Reference;
2457
2458    --------------------------------
2459    -- Analyze_Selected_Component --
2460    --------------------------------
2461
2462    --  Prefix is a record type or a task or protected type. In the
2463    --  later case, the selector must denote a visible entry.
2464
2465    procedure Analyze_Selected_Component (N : Node_Id) is
2466       Name        : constant Node_Id := Prefix (N);
2467       Sel         : constant Node_Id := Selector_Name (N);
2468       Comp        : Entity_Id;
2469       Entity_List : Entity_Id;
2470       Prefix_Type : Entity_Id;
2471       Pent        : Entity_Id := Empty;
2472       Act_Decl    : Node_Id;
2473       In_Scope    : Boolean;
2474       Parent_N    : Node_Id;
2475
2476    --  Start of processing for Analyze_Selected_Component
2477
2478    begin
2479       Set_Etype (N, Any_Type);
2480
2481       if Is_Overloaded (Name) then
2482          Analyze_Overloaded_Selected_Component (N);
2483          return;
2484
2485       elsif Etype (Name) = Any_Type then
2486          Set_Entity (Sel, Any_Id);
2487          Set_Etype (Sel, Any_Type);
2488          return;
2489
2490       else
2491          --  Function calls that are prefixes of selected components must be
2492          --  fully resolved in case we need to build an actual subtype, or
2493          --  do some other operation requiring a fully resolved prefix.
2494
2495          --  Note: Resolving all Nkinds of nodes here doesn't work.
2496          --  (Breaks 2129-008) ???.
2497
2498          if Nkind (Name) = N_Function_Call then
2499             Resolve (Name);
2500          end if;
2501
2502          Prefix_Type := Etype (Name);
2503       end if;
2504
2505       if Is_Access_Type (Prefix_Type) then
2506
2507          --  A RACW object can never be used as prefix of a selected
2508          --  component since that means it is dereferenced without
2509          --  being a controlling operand of a dispatching operation
2510          --  (RM E.2.2(15)).
2511
2512          if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
2513            and then Comes_From_Source (N)
2514          then
2515             Error_Msg_N
2516               ("invalid dereference of a remote access to class-wide value",
2517                N);
2518
2519          --  Normal case of selected component applied to access type
2520
2521          else
2522             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2523
2524             if Is_Entity_Name (Name) then
2525                Pent := Entity (Name);
2526             elsif Nkind (Name) = N_Selected_Component
2527               and then Is_Entity_Name (Selector_Name (Name))
2528             then
2529                Pent := Entity (Selector_Name (Name));
2530             end if;
2531
2532             Process_Implicit_Dereference_Prefix (Pent, Name);
2533          end if;
2534
2535          Prefix_Type := Designated_Type (Prefix_Type);
2536       end if;
2537
2538       if Ekind (Prefix_Type) = E_Private_Subtype then
2539          Prefix_Type := Base_Type (Prefix_Type);
2540       end if;
2541
2542       Entity_List := Prefix_Type;
2543
2544       --  For class-wide types, use the entity list of the root type. This
2545       --  indirection is specially important for private extensions because
2546       --  only the root type get switched (not the class-wide type).
2547
2548       if Is_Class_Wide_Type (Prefix_Type) then
2549          Entity_List := Root_Type (Prefix_Type);
2550       end if;
2551
2552       Comp := First_Entity (Entity_List);
2553
2554       --  If the selector has an original discriminant, the node appears in
2555       --  an instance. Replace the discriminant with the corresponding one
2556       --  in the current discriminated type. For nested generics, this must
2557       --  be done transitively, so note the new original discriminant.
2558
2559       if Nkind (Sel) = N_Identifier
2560         and then Present (Original_Discriminant (Sel))
2561       then
2562          Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
2563
2564          --  Mark entity before rewriting, for completeness and because
2565          --  subsequent semantic checks might examine the original node.
2566
2567          Set_Entity (Sel, Comp);
2568          Rewrite (Selector_Name (N),
2569            New_Occurrence_Of (Comp, Sloc (N)));
2570          Set_Original_Discriminant (Selector_Name (N), Comp);
2571          Set_Etype (N, Etype (Comp));
2572
2573          if Is_Access_Type (Etype (Name)) then
2574             Insert_Explicit_Dereference (Name);
2575             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2576          end if;
2577
2578       elsif Is_Record_Type (Prefix_Type) then
2579
2580          --  Find component with given name
2581
2582          while Present (Comp) loop
2583             if Chars (Comp) = Chars (Sel)
2584               and then Is_Visible_Component (Comp)
2585             then
2586                Set_Entity_With_Style_Check (Sel, Comp);
2587                Generate_Reference (Comp, Sel);
2588
2589                Set_Etype (Sel, Etype (Comp));
2590
2591                if Ekind (Comp) = E_Discriminant then
2592                   if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
2593                      Error_Msg_N
2594                        ("cannot reference discriminant of Unchecked_Union",
2595                         Sel);
2596                   end if;
2597
2598                   if Is_Generic_Type (Prefix_Type)
2599                        or else
2600                      Is_Generic_Type (Root_Type (Prefix_Type))
2601                   then
2602                      Set_Original_Discriminant (Sel, Comp);
2603                   end if;
2604                end if;
2605
2606                --  Resolve the prefix early otherwise it is not possible to
2607                --  build the actual subtype of the component: it may need
2608                --  to duplicate this prefix and duplication is only allowed
2609                --  on fully resolved expressions.
2610
2611                Resolve (Name);
2612
2613                --  We never need an actual subtype for the case of a selection
2614                --  for a indexed component of a non-packed array, since in
2615                --  this case gigi generates all the checks and can find the
2616                --  necessary bounds information.
2617
2618                --  We also do not need an actual subtype for the case of
2619                --  a first, last, length, or range attribute applied to a
2620                --  non-packed array, since gigi can again get the bounds in
2621                --  these cases (gigi cannot handle the packed case, since it
2622                --  has the bounds of the packed array type, not the original
2623                --  bounds of the type). However, if the prefix is itself a
2624                --  selected component, as in a.b.c (i), gigi may regard a.b.c
2625                --  as a dynamic-sized temporary, so we do generate an actual
2626                --  subtype for this case.
2627
2628                Parent_N := Parent (N);
2629
2630                if not Is_Packed (Etype (Comp))
2631                  and then
2632                    ((Nkind (Parent_N) = N_Indexed_Component
2633                       and then Nkind (Name) /= N_Selected_Component)
2634                      or else
2635                       (Nkind (Parent_N) = N_Attribute_Reference
2636                          and then (Attribute_Name (Parent_N) = Name_First
2637                                      or else
2638                                    Attribute_Name (Parent_N) = Name_Last
2639                                      or else
2640                                    Attribute_Name (Parent_N) = Name_Length
2641                                      or else
2642                                    Attribute_Name (Parent_N) = Name_Range)))
2643                then
2644                   Set_Etype (N, Etype (Comp));
2645
2646                --  In all other cases, we currently build an actual subtype. It
2647                --  seems likely that many of these cases can be avoided, but
2648                --  right now, the front end makes direct references to the
2649                --  bounds (e.g. in generating a length check), and if we do
2650                --  not make an actual subtype, we end up getting a direct
2651                --  reference to a discriminant which will not do.
2652
2653                --  Comment needs revision, "in all other cases" does not
2654                --  reasonably describe the situation below with an elsif???
2655
2656                elsif Expander_Active then
2657                   Act_Decl :=
2658                     Build_Actual_Subtype_Of_Component (Etype (Comp), N);
2659                   Insert_Action (N, Act_Decl);
2660
2661                   if No (Act_Decl) then
2662                      Set_Etype (N, Etype (Comp));
2663
2664                   else
2665                      --  Component type depends on discriminants. Enter the
2666                      --  main attributes of the subtype.
2667
2668                      declare
2669                         Subt : constant Entity_Id :=
2670                                  Defining_Identifier (Act_Decl);
2671
2672                      begin
2673                         Set_Etype (Subt, Base_Type (Etype (Comp)));
2674                         Set_Ekind (Subt, Ekind (Etype (Comp)));
2675                         Set_Etype (N, Subt);
2676                      end;
2677                   end if;
2678
2679                else
2680                   Set_Etype (N, Etype (Comp));
2681                end if;
2682
2683                return;
2684             end if;
2685
2686             Next_Entity (Comp);
2687          end loop;
2688
2689          --  Ada 2005 (AI-252)
2690
2691          if Ada_Version >= Ada_05
2692            and then Is_Tagged_Type (Prefix_Type)
2693            and then Try_Object_Operation (N)
2694          then
2695             return;
2696
2697             --  If the transformation fails, it will be necessary
2698             --  to redo the analysis with all errors enabled, to indicate
2699             --  candidate interpretations and reasons for each failure ???
2700
2701          end if;
2702
2703       elsif Is_Private_Type (Prefix_Type) then
2704
2705          --  Allow access only to discriminants of the type. If the
2706          --  type has no full view, gigi uses the parent type for
2707          --  the components, so we do the same here.
2708
2709          if No (Full_View (Prefix_Type)) then
2710             Entity_List := Root_Type (Base_Type (Prefix_Type));
2711             Comp := First_Entity (Entity_List);
2712          end if;
2713
2714          while Present (Comp) loop
2715             if Chars (Comp) = Chars (Sel) then
2716                if Ekind (Comp) = E_Discriminant then
2717                   Set_Entity_With_Style_Check (Sel, Comp);
2718                   Generate_Reference (Comp, Sel);
2719
2720                   Set_Etype (Sel, Etype (Comp));
2721                   Set_Etype (N,   Etype (Comp));
2722
2723                   if Is_Generic_Type (Prefix_Type)
2724                     or else
2725                      Is_Generic_Type (Root_Type (Prefix_Type))
2726                   then
2727                      Set_Original_Discriminant (Sel, Comp);
2728                   end if;
2729
2730                else
2731                   Error_Msg_NE
2732                     ("invisible selector for }",
2733                      N, First_Subtype (Prefix_Type));
2734                   Set_Entity (Sel, Any_Id);
2735                   Set_Etype (N, Any_Type);
2736                end if;
2737
2738                return;
2739             end if;
2740
2741             Next_Entity (Comp);
2742          end loop;
2743
2744       elsif Is_Concurrent_Type (Prefix_Type) then
2745
2746          --  Prefix is concurrent type. Find visible operation with given name
2747          --  For a task, this can only include entries or discriminants if
2748          --  the task type is not an enclosing scope. If it is an enclosing
2749          --  scope (e.g. in an inner task) then all entities are visible, but
2750          --  the prefix must denote the enclosing scope, i.e. can only be
2751          --  a direct name or an expanded name.
2752
2753          Set_Etype (Sel,  Any_Type);
2754          In_Scope := In_Open_Scopes (Prefix_Type);
2755
2756          while Present (Comp) loop
2757             if Chars (Comp) = Chars (Sel) then
2758                if Is_Overloadable (Comp) then
2759                   Add_One_Interp (Sel, Comp, Etype (Comp));
2760
2761                elsif Ekind (Comp) = E_Discriminant
2762                  or else Ekind (Comp) = E_Entry_Family
2763                  or else (In_Scope
2764                    and then Is_Entity_Name (Name))
2765                then
2766                   Set_Entity_With_Style_Check (Sel, Comp);
2767                   Generate_Reference (Comp, Sel);
2768
2769                else
2770                   goto Next_Comp;
2771                end if;
2772
2773                Set_Etype (Sel, Etype (Comp));
2774                Set_Etype (N,   Etype (Comp));
2775
2776                if Ekind (Comp) = E_Discriminant then
2777                   Set_Original_Discriminant (Sel, Comp);
2778                end if;
2779
2780                --  For access type case, introduce explicit deference for
2781                --  more uniform treatment of entry calls.
2782
2783                if Is_Access_Type (Etype (Name)) then
2784                   Insert_Explicit_Dereference (Name);
2785                   Error_Msg_NW
2786                     (Warn_On_Dereference, "?implicit dereference", N);
2787                end if;
2788             end if;
2789
2790             <<Next_Comp>>
2791                Next_Entity (Comp);
2792                exit when not In_Scope
2793                  and then
2794                    Comp = First_Private_Entity (Base_Type (Prefix_Type));
2795          end loop;
2796
2797          Set_Is_Overloaded (N, Is_Overloaded (Sel));
2798
2799       else
2800          --  Invalid prefix
2801
2802          Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
2803       end if;
2804
2805       --  If N still has no type, the component is not defined in the prefix
2806
2807       if Etype (N) = Any_Type then
2808
2809          --  If the prefix is a single concurrent object, use its name in
2810          --  the error message, rather than that of its anonymous type.
2811
2812          if Is_Concurrent_Type (Prefix_Type)
2813            and then Is_Internal_Name (Chars (Prefix_Type))
2814            and then not Is_Derived_Type (Prefix_Type)
2815            and then Is_Entity_Name (Name)
2816          then
2817
2818             Error_Msg_Node_2 := Entity (Name);
2819             Error_Msg_NE ("no selector& for&", N, Sel);
2820
2821             Check_Misspelled_Selector (Entity_List, Sel);
2822
2823          elsif Is_Generic_Type (Prefix_Type)
2824            and then Ekind (Prefix_Type) = E_Record_Type_With_Private
2825            and then Prefix_Type /= Etype (Prefix_Type)
2826            and then Is_Record_Type (Etype (Prefix_Type))
2827          then
2828             --  If this is a derived formal type, the parent may have a
2829             --  different visibility at this point. Try for an inherited
2830             --  component before reporting an error.
2831
2832             Set_Etype (Prefix (N), Etype (Prefix_Type));
2833             Analyze_Selected_Component (N);
2834             return;
2835
2836          elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
2837            and then Is_Generic_Actual_Type (Prefix_Type)
2838            and then Present (Full_View (Prefix_Type))
2839          then
2840             --  Similarly, if this the actual for a formal derived type, the
2841             --  component inherited from the generic parent may not be visible
2842             --  in the actual, but the selected component is legal.
2843
2844             declare
2845                Comp : Entity_Id;
2846
2847             begin
2848                Comp :=
2849                  First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
2850                while Present (Comp) loop
2851                   if Chars (Comp) = Chars (Sel) then
2852                      Set_Entity_With_Style_Check (Sel, Comp);
2853                      Set_Etype (Sel, Etype (Comp));
2854                      Set_Etype (N,   Etype (Comp));
2855                      exit;
2856                   end if;
2857
2858                   Next_Component (Comp);
2859                end loop;
2860
2861                pragma Assert (Etype (N) /= Any_Type);
2862             end;
2863
2864          else
2865             if Ekind (Prefix_Type) = E_Record_Subtype then
2866
2867                --  Check whether this is a component of the base type
2868                --  which is absent from a statically constrained subtype.
2869                --  This will raise constraint error at run-time, but is
2870                --  not a compile-time error. When the selector is illegal
2871                --  for base type as well fall through and generate a
2872                --  compilation error anyway.
2873
2874                Comp := First_Component (Base_Type (Prefix_Type));
2875                while Present (Comp) loop
2876                   if Chars (Comp) = Chars (Sel)
2877                     and then Is_Visible_Component (Comp)
2878                   then
2879                      Set_Entity_With_Style_Check (Sel, Comp);
2880                      Generate_Reference (Comp, Sel);
2881                      Set_Etype (Sel, Etype (Comp));
2882                      Set_Etype (N,   Etype (Comp));
2883
2884                      --  Emit appropriate message. Gigi will replace the
2885                      --  node subsequently with the appropriate Raise.
2886
2887                      Apply_Compile_Time_Constraint_Error
2888                        (N, "component not present in }?",
2889                         CE_Discriminant_Check_Failed,
2890                         Ent => Prefix_Type, Rep => False);
2891                      Set_Raises_Constraint_Error (N);
2892                      return;
2893                   end if;
2894
2895                   Next_Component (Comp);
2896                end loop;
2897
2898             end if;
2899
2900             Error_Msg_Node_2 := First_Subtype (Prefix_Type);
2901             Error_Msg_NE ("no selector& for}", N, Sel);
2902
2903             Check_Misspelled_Selector (Entity_List, Sel);
2904
2905          end if;
2906
2907          Set_Entity (Sel, Any_Id);
2908          Set_Etype (Sel, Any_Type);
2909       end if;
2910    end Analyze_Selected_Component;
2911
2912    ---------------------------
2913    -- Analyze_Short_Circuit --
2914    ---------------------------
2915
2916    procedure Analyze_Short_Circuit (N : Node_Id) is
2917       L   : constant Node_Id := Left_Opnd  (N);
2918       R   : constant Node_Id := Right_Opnd (N);
2919       Ind : Interp_Index;
2920       It  : Interp;
2921
2922    begin
2923       Analyze_Expression (L);
2924       Analyze_Expression (R);
2925       Set_Etype (N, Any_Type);
2926
2927       if not Is_Overloaded (L) then
2928
2929          if Root_Type (Etype (L)) = Standard_Boolean
2930            and then Has_Compatible_Type (R, Etype (L))
2931          then
2932             Add_One_Interp (N, Etype (L), Etype (L));
2933          end if;
2934
2935       else
2936          Get_First_Interp (L, Ind, It);
2937
2938          while Present (It.Typ) loop
2939             if Root_Type (It.Typ) = Standard_Boolean
2940               and then Has_Compatible_Type (R, It.Typ)
2941             then
2942                Add_One_Interp (N, It.Typ, It.Typ);
2943             end if;
2944
2945             Get_Next_Interp (Ind, It);
2946          end loop;
2947       end if;
2948
2949       --  Here we have failed to find an interpretation. Clearly we
2950       --  know that it is not the case that both operands can have
2951       --  an interpretation of Boolean, but this is by far the most
2952       --  likely intended interpretation. So we simply resolve both
2953       --  operands as Booleans, and at least one of these resolutions
2954       --  will generate an error message, and we do not need to give
2955       --  a further error message on the short circuit operation itself.
2956
2957       if Etype (N) = Any_Type then
2958          Resolve (L, Standard_Boolean);
2959          Resolve (R, Standard_Boolean);
2960          Set_Etype (N, Standard_Boolean);
2961       end if;
2962    end Analyze_Short_Circuit;
2963
2964    -------------------
2965    -- Analyze_Slice --
2966    -------------------
2967
2968    procedure Analyze_Slice (N : Node_Id) is
2969       P          : constant Node_Id := Prefix (N);
2970       D          : constant Node_Id := Discrete_Range (N);
2971       Array_Type : Entity_Id;
2972
2973       procedure Analyze_Overloaded_Slice;
2974       --  If the prefix is overloaded, select those interpretations that
2975       --  yield a one-dimensional array type.
2976
2977       ------------------------------
2978       -- Analyze_Overloaded_Slice --
2979       ------------------------------
2980
2981       procedure Analyze_Overloaded_Slice is
2982          I   : Interp_Index;
2983          It  : Interp;
2984          Typ : Entity_Id;
2985
2986       begin
2987          Set_Etype (N, Any_Type);
2988
2989          Get_First_Interp (P, I, It);
2990          while Present (It.Nam) loop
2991             Typ := It.Typ;
2992
2993             if Is_Access_Type (Typ) then
2994                Typ := Designated_Type (Typ);
2995                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2996             end if;
2997
2998             if Is_Array_Type (Typ)
2999               and then Number_Dimensions (Typ) = 1
3000               and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
3001             then
3002                Add_One_Interp (N, Typ, Typ);
3003             end if;
3004
3005             Get_Next_Interp (I, It);
3006          end loop;
3007
3008          if Etype (N) = Any_Type then
3009             Error_Msg_N ("expect array type in prefix of slice",  N);
3010          end if;
3011       end Analyze_Overloaded_Slice;
3012
3013    --  Start of processing for Analyze_Slice
3014
3015    begin
3016       Analyze (P);
3017       Analyze (D);
3018
3019       if Is_Overloaded (P) then
3020          Analyze_Overloaded_Slice;
3021
3022       else
3023          Array_Type := Etype (P);
3024          Set_Etype (N, Any_Type);
3025
3026          if Is_Access_Type (Array_Type) then
3027             Array_Type := Designated_Type (Array_Type);
3028             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3029          end if;
3030
3031          if not Is_Array_Type (Array_Type) then
3032             Wrong_Type (P, Any_Array);
3033
3034          elsif Number_Dimensions (Array_Type) > 1 then
3035             Error_Msg_N
3036               ("type is not one-dimensional array in slice prefix", N);
3037
3038          elsif not
3039            Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
3040          then
3041             Wrong_Type (D, Etype (First_Index (Array_Type)));
3042
3043          else
3044             Set_Etype (N, Array_Type);
3045          end if;
3046       end if;
3047    end Analyze_Slice;
3048
3049    -----------------------------
3050    -- Analyze_Type_Conversion --
3051    -----------------------------
3052
3053    procedure Analyze_Type_Conversion (N : Node_Id) is
3054       Expr : constant Node_Id := Expression (N);
3055       T    : Entity_Id;
3056
3057    begin
3058       --  If Conversion_OK is set, then the Etype is already set, and the
3059       --  only processing required is to analyze the expression. This is
3060       --  used to construct certain "illegal" conversions which are not
3061       --  allowed by Ada semantics, but can be handled OK by Gigi, see
3062       --  Sinfo for further details.
3063
3064       if Conversion_OK (N) then
3065          Analyze (Expr);
3066          return;
3067       end if;
3068
3069       --  Otherwise full type analysis is required, as well as some semantic
3070       --  checks to make sure the argument of the conversion is appropriate.
3071
3072       Find_Type (Subtype_Mark (N));
3073       T := Entity (Subtype_Mark (N));
3074       Set_Etype (N, T);
3075       Check_Fully_Declared (T, N);
3076       Analyze_Expression (Expr);
3077       Validate_Remote_Type_Type_Conversion (N);
3078
3079       --  Only remaining step is validity checks on the argument. These
3080       --  are skipped if the conversion does not come from the source.
3081
3082       if not Comes_From_Source (N) then
3083          return;
3084
3085       elsif Nkind (Expr) = N_Null then
3086          Error_Msg_N ("argument of conversion cannot be null", N);
3087          Error_Msg_N ("\use qualified expression instead", N);
3088          Set_Etype (N, Any_Type);
3089
3090       elsif Nkind (Expr) = N_Aggregate then
3091          Error_Msg_N ("argument of conversion cannot be aggregate", N);
3092          Error_Msg_N ("\use qualified expression instead", N);
3093
3094       elsif Nkind (Expr) = N_Allocator then
3095          Error_Msg_N ("argument of conversion cannot be an allocator", N);
3096          Error_Msg_N ("\use qualified expression instead", N);
3097
3098       elsif Nkind (Expr) = N_String_Literal then
3099          Error_Msg_N ("argument of conversion cannot be string literal", N);
3100          Error_Msg_N ("\use qualified expression instead", N);
3101
3102       elsif Nkind (Expr) = N_Character_Literal then
3103          if Ada_Version = Ada_83 then
3104             Resolve (Expr, T);
3105          else
3106             Error_Msg_N ("argument of conversion cannot be character literal",
3107               N);
3108             Error_Msg_N ("\use qualified expression instead", N);
3109          end if;
3110
3111       elsif Nkind (Expr) = N_Attribute_Reference
3112         and then
3113           (Attribute_Name (Expr) = Name_Access            or else
3114            Attribute_Name (Expr) = Name_Unchecked_Access  or else
3115            Attribute_Name (Expr) = Name_Unrestricted_Access)
3116       then
3117          Error_Msg_N ("argument of conversion cannot be access", N);
3118          Error_Msg_N ("\use qualified expression instead", N);
3119       end if;
3120    end Analyze_Type_Conversion;
3121
3122    ----------------------
3123    -- Analyze_Unary_Op --
3124    ----------------------
3125
3126    procedure Analyze_Unary_Op (N : Node_Id) is
3127       R     : constant Node_Id := Right_Opnd (N);
3128       Op_Id : Entity_Id := Entity (N);
3129
3130    begin
3131       Set_Etype (N, Any_Type);
3132       Candidate_Type := Empty;
3133
3134       Analyze_Expression (R);
3135
3136       if Present (Op_Id) then
3137          if Ekind (Op_Id) = E_Operator then
3138             Find_Unary_Types (R, Op_Id,  N);
3139          else
3140             Add_One_Interp (N, Op_Id, Etype (Op_Id));
3141          end if;
3142
3143       else
3144          Op_Id := Get_Name_Entity_Id (Chars (N));
3145          while Present (Op_Id) loop
3146             if Ekind (Op_Id) = E_Operator then
3147                if No (Next_Entity (First_Entity (Op_Id))) then
3148                   Find_Unary_Types (R, Op_Id,  N);
3149                end if;
3150
3151             elsif Is_Overloadable (Op_Id) then
3152                Analyze_User_Defined_Unary_Op (N, Op_Id);
3153             end if;
3154
3155             Op_Id := Homonym (Op_Id);
3156          end loop;
3157       end if;
3158
3159       Operator_Check (N);
3160    end Analyze_Unary_Op;
3161
3162    ----------------------------------
3163    -- Analyze_Unchecked_Expression --
3164    ----------------------------------
3165
3166    procedure Analyze_Unchecked_Expression (N : Node_Id) is
3167    begin
3168       Analyze (Expression (N), Suppress => All_Checks);
3169       Set_Etype (N, Etype (Expression (N)));
3170       Save_Interps (Expression (N), N);
3171    end Analyze_Unchecked_Expression;
3172
3173    ---------------------------------------
3174    -- Analyze_Unchecked_Type_Conversion --
3175    ---------------------------------------
3176
3177    procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
3178    begin
3179       Find_Type (Subtype_Mark (N));
3180       Analyze_Expression (Expression (N));
3181       Set_Etype (N, Entity (Subtype_Mark (N)));
3182    end Analyze_Unchecked_Type_Conversion;
3183
3184    ------------------------------------
3185    -- Analyze_User_Defined_Binary_Op --
3186    ------------------------------------
3187
3188    procedure Analyze_User_Defined_Binary_Op
3189      (N     : Node_Id;
3190       Op_Id : Entity_Id)
3191    is
3192    begin
3193       --  Only do analysis if the operator Comes_From_Source, since otherwise
3194       --  the operator was generated by the expander, and all such operators
3195       --  always refer to the operators in package Standard.
3196
3197       if Comes_From_Source (N) then
3198          declare
3199             F1 : constant Entity_Id := First_Formal (Op_Id);
3200             F2 : constant Entity_Id := Next_Formal (F1);
3201
3202          begin
3203             --  Verify that Op_Id is a visible binary function. Note that since
3204             --  we know Op_Id is overloaded, potentially use visible means use
3205             --  visible for sure (RM 9.4(11)).
3206
3207             if Ekind (Op_Id) = E_Function
3208               and then Present (F2)
3209               and then (Is_Immediately_Visible (Op_Id)
3210                          or else Is_Potentially_Use_Visible (Op_Id))
3211               and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
3212               and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
3213             then
3214                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3215
3216                if Debug_Flag_E then
3217                   Write_Str ("user defined operator ");
3218                   Write_Name (Chars (Op_Id));
3219                   Write_Str (" on node ");
3220                   Write_Int (Int (N));
3221                   Write_Eol;
3222                end if;
3223             end if;
3224          end;
3225       end if;
3226    end Analyze_User_Defined_Binary_Op;
3227
3228    -----------------------------------
3229    -- Analyze_User_Defined_Unary_Op --
3230    -----------------------------------
3231
3232    procedure Analyze_User_Defined_Unary_Op
3233      (N     : Node_Id;
3234       Op_Id : Entity_Id)
3235    is
3236    begin
3237       --  Only do analysis if the operator Comes_From_Source, since otherwise
3238       --  the operator was generated by the expander, and all such operators
3239       --  always refer to the operators in package Standard.
3240
3241       if Comes_From_Source (N) then
3242          declare
3243             F : constant Entity_Id := First_Formal (Op_Id);
3244
3245          begin
3246             --  Verify that Op_Id is a visible unary function. Note that since
3247             --  we know Op_Id is overloaded, potentially use visible means use
3248             --  visible for sure (RM 9.4(11)).
3249
3250             if Ekind (Op_Id) = E_Function
3251               and then No (Next_Formal (F))
3252               and then (Is_Immediately_Visible (Op_Id)
3253                          or else Is_Potentially_Use_Visible (Op_Id))
3254               and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
3255             then
3256                Add_One_Interp (N, Op_Id, Etype (Op_Id));
3257             end if;
3258          end;
3259       end if;
3260    end Analyze_User_Defined_Unary_Op;
3261
3262    ---------------------------
3263    -- Check_Arithmetic_Pair --
3264    ---------------------------
3265
3266    procedure Check_Arithmetic_Pair
3267      (T1, T2 : Entity_Id;
3268       Op_Id  : Entity_Id;
3269       N      : Node_Id)
3270    is
3271       Op_Name : constant Name_Id   := Chars (Op_Id);
3272
3273       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
3274       --  Check whether the fixed-point type Typ has a user-defined operator
3275       --  (multiplication or division) that should hide the corresponding
3276       --  predefined operator. Used to implement Ada 2005 AI-264, to make
3277       --  such operators more visible and therefore useful.
3278
3279       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
3280       --  Get specific type (i.e. non-universal type if there is one)
3281
3282       ------------------
3283       -- Has_Fixed_Op --
3284       ------------------
3285
3286       function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
3287          Ent : Entity_Id;
3288          F1  : Entity_Id;
3289          F2  : Entity_Id;
3290
3291       begin
3292          --  The operation is treated as primitive if it is declared in the
3293          --  same scope as the type, and therefore on the same entity chain.
3294
3295          Ent := Next_Entity (Typ);
3296          while Present (Ent) loop
3297             if Chars (Ent) = Chars (Op) then
3298                F1 := First_Formal (Ent);
3299                F2 := Next_Formal (F1);
3300
3301                --  The operation counts as primitive if either operand or
3302                --  result are of the given type, and both operands are fixed
3303                --  point types.
3304
3305                if (Etype (F1) = Typ
3306                     and then Is_Fixed_Point_Type (Etype (F2)))
3307
3308                  or else
3309                    (Etype (F2) = Typ
3310                      and then Is_Fixed_Point_Type (Etype (F1)))
3311
3312                  or else
3313                    (Etype (Ent) = Typ
3314                      and then Is_Fixed_Point_Type (Etype (F1))
3315                      and then Is_Fixed_Point_Type (Etype (F2)))
3316                then
3317                   return True;
3318                end if;
3319             end if;
3320
3321             Next_Entity (Ent);
3322          end loop;
3323
3324          return False;
3325       end Has_Fixed_Op;
3326
3327       -------------------
3328       -- Specific_Type --
3329       -------------------
3330
3331       function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
3332       begin
3333          if T1 = Universal_Integer or else T1 = Universal_Real then
3334             return Base_Type (T2);
3335          else
3336             return Base_Type (T1);
3337          end if;
3338       end Specific_Type;
3339
3340    --  Start of processing for Check_Arithmetic_Pair
3341
3342    begin
3343       if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
3344
3345          if Is_Numeric_Type (T1)
3346            and then Is_Numeric_Type (T2)
3347            and then (Covers (T1, T2) or else Covers (T2, T1))
3348          then
3349             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3350          end if;
3351
3352       elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
3353
3354          if Is_Fixed_Point_Type (T1)
3355            and then (Is_Fixed_Point_Type (T2)
3356                        or else T2 = Universal_Real)
3357          then
3358             --  If Treat_Fixed_As_Integer is set then the Etype is already set
3359             --  and no further processing is required (this is the case of an
3360             --  operator constructed by Exp_Fixd for a fixed point operation)
3361             --  Otherwise add one interpretation with universal fixed result
3362             --  If the operator is given in  functional notation, it comes
3363             --  from source and Fixed_As_Integer cannot apply.
3364
3365             if (Nkind (N) not in N_Op
3366                  or else not Treat_Fixed_As_Integer (N))
3367               and then
3368                 (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
3369                   or else Nkind (Parent (N)) = N_Type_Conversion)
3370             then
3371                Add_One_Interp (N, Op_Id, Universal_Fixed);
3372             end if;
3373
3374          elsif Is_Fixed_Point_Type (T2)
3375            and then (Nkind (N) not in N_Op
3376                       or else not Treat_Fixed_As_Integer (N))
3377            and then T1 = Universal_Real
3378            and then
3379              (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
3380                or else Nkind (Parent (N)) = N_Type_Conversion)
3381          then
3382             Add_One_Interp (N, Op_Id, Universal_Fixed);
3383
3384          elsif Is_Numeric_Type (T1)
3385            and then Is_Numeric_Type (T2)
3386            and then (Covers (T1, T2) or else Covers (T2, T1))
3387          then
3388             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3389
3390          elsif Is_Fixed_Point_Type (T1)
3391            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3392                        or else T2 = Universal_Integer)
3393          then
3394             Add_One_Interp (N, Op_Id, T1);
3395
3396          elsif T2 = Universal_Real
3397            and then Base_Type (T1) = Base_Type (Standard_Integer)
3398            and then Op_Name = Name_Op_Multiply
3399          then
3400             Add_One_Interp (N, Op_Id, Any_Fixed);
3401
3402          elsif T1 = Universal_Real
3403            and then Base_Type (T2) = Base_Type (Standard_Integer)
3404          then
3405             Add_One_Interp (N, Op_Id, Any_Fixed);
3406
3407          elsif Is_Fixed_Point_Type (T2)
3408            and then (Base_Type (T1) = Base_Type (Standard_Integer)
3409                        or else T1 = Universal_Integer)
3410            and then Op_Name = Name_Op_Multiply
3411          then
3412             Add_One_Interp (N, Op_Id, T2);
3413
3414          elsif T1 = Universal_Real and then T2 = Universal_Integer then
3415             Add_One_Interp (N, Op_Id, T1);
3416
3417          elsif T2 = Universal_Real
3418            and then T1 = Universal_Integer
3419            and then Op_Name = Name_Op_Multiply
3420          then
3421             Add_One_Interp (N, Op_Id, T2);
3422          end if;
3423
3424       elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
3425
3426          --  Note: The fixed-point operands case with Treat_Fixed_As_Integer
3427          --  set does not require any special processing, since the Etype is
3428          --  already set (case of operation constructed by Exp_Fixed).
3429
3430          if Is_Integer_Type (T1)
3431            and then (Covers (T1, T2) or else Covers (T2, T1))
3432          then
3433             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
3434          end if;
3435
3436       elsif Op_Name = Name_Op_Expon then
3437          if Is_Numeric_Type (T1)
3438            and then not Is_Fixed_Point_Type (T1)
3439            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3440                       or else T2 = Universal_Integer)
3441          then
3442             Add_One_Interp (N, Op_Id, Base_Type (T1));
3443          end if;
3444
3445       else pragma Assert (Nkind (N) in N_Op_Shift);
3446
3447          --  If not one of the predefined operators, the node may be one
3448          --  of the intrinsic functions. Its kind is always specific, and
3449          --  we can use it directly, rather than the name of the operation.
3450
3451          if Is_Integer_Type (T1)
3452            and then (Base_Type (T2) = Base_Type (Standard_Integer)
3453                       or else T2 = Universal_Integer)
3454          then
3455             Add_One_Interp (N, Op_Id, Base_Type (T1));
3456          end if;
3457       end if;
3458    end Check_Arithmetic_Pair;
3459
3460    -------------------------------
3461    -- Check_Misspelled_Selector --
3462    -------------------------------
3463
3464    procedure Check_Misspelled_Selector
3465      (Prefix : Entity_Id;
3466       Sel    : Node_Id)
3467    is
3468       Max_Suggestions   : constant := 2;
3469       Nr_Of_Suggestions : Natural := 0;
3470
3471       Suggestion_1 : Entity_Id := Empty;
3472       Suggestion_2 : Entity_Id := Empty;
3473
3474       Comp : Entity_Id;
3475
3476    begin
3477       --  All the components of the prefix of selector Sel are matched
3478       --  against  Sel and a count is maintained of possible misspellings.
3479       --  When at the end of the analysis there are one or two (not more!)
3480       --  possible misspellings, these misspellings will be suggested as
3481       --  possible correction.
3482
3483       if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
3484
3485          --  Concurrent types should be handled as well ???
3486
3487          return;
3488       end if;
3489
3490       Get_Name_String (Chars (Sel));
3491
3492       declare
3493          S  : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
3494
3495       begin
3496          Comp  := First_Entity (Prefix);
3497          while Nr_Of_Suggestions <= Max_Suggestions
3498             and then Present (Comp)
3499          loop
3500             if Is_Visible_Component (Comp) then
3501                Get_Name_String (Chars (Comp));
3502
3503                if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
3504                   Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
3505
3506                   case Nr_Of_Suggestions is
3507                      when 1      => Suggestion_1 := Comp;
3508                      when 2      => Suggestion_2 := Comp;
3509                      when others => exit;
3510                   end case;
3511                end if;
3512             end if;
3513
3514             Comp := Next_Entity (Comp);
3515          end loop;
3516
3517          --  Report at most two suggestions
3518
3519          if Nr_Of_Suggestions = 1 then
3520             Error_Msg_NE ("\possible misspelling of&", Sel, Suggestion_1);
3521
3522          elsif Nr_Of_Suggestions = 2 then
3523             Error_Msg_Node_2 := Suggestion_2;
3524             Error_Msg_NE ("\possible misspelling of& or&",
3525               Sel, Suggestion_1);
3526          end if;
3527       end;
3528    end Check_Misspelled_Selector;
3529
3530    ----------------------
3531    -- Defined_In_Scope --
3532    ----------------------
3533
3534    function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
3535    is
3536       S1 : constant Entity_Id := Scope (Base_Type (T));
3537    begin
3538       return S1 = S
3539         or else (S1 = System_Aux_Id and then S = Scope (S1));
3540    end Defined_In_Scope;
3541
3542    -------------------
3543    -- Diagnose_Call --
3544    -------------------
3545
3546    procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
3547       Actual           : Node_Id;
3548       X                : Interp_Index;
3549       It               : Interp;
3550       Success          : Boolean;
3551       Err_Mode         : Boolean;
3552       New_Nam          : Node_Id;
3553       Void_Interp_Seen : Boolean := False;
3554
3555    begin
3556       if Ada_Version >= Ada_05 then
3557          Actual := First_Actual (N);
3558          while Present (Actual) loop
3559
3560             --  Ada 2005 (AI-50217): Post an error in case of premature
3561             --  usage of an entity from the limited view.
3562
3563             if not Analyzed (Etype (Actual))
3564              and then From_With_Type (Etype (Actual))
3565             then
3566                Error_Msg_Qual_Level := 1;
3567                Error_Msg_NE
3568                 ("missing with_clause for scope of imported type&",
3569                   Actual, Etype (Actual));
3570                Error_Msg_Qual_Level := 0;
3571             end if;
3572
3573             Next_Actual (Actual);
3574          end loop;
3575       end if;
3576
3577       --   Analyze each candidate call again, with full error reporting
3578       --   for each.
3579
3580       Error_Msg_N
3581         ("no candidate interpretations match the actuals:!", Nam);
3582       Err_Mode := All_Errors_Mode;
3583       All_Errors_Mode := True;
3584
3585       --  If this is a call to an operation of a concurrent type,
3586       --  the failed interpretations have been removed from the
3587       --  name. Recover them to provide full diagnostics.
3588
3589       if Nkind (Parent (Nam)) = N_Selected_Component then
3590          Set_Entity (Nam, Empty);
3591          New_Nam := New_Copy_Tree (Parent (Nam));
3592          Set_Is_Overloaded (New_Nam, False);
3593          Set_Is_Overloaded (Selector_Name (New_Nam), False);
3594          Set_Parent (New_Nam, Parent (Parent (Nam)));
3595          Analyze_Selected_Component (New_Nam);
3596          Get_First_Interp (Selector_Name (New_Nam), X, It);
3597       else
3598          Get_First_Interp (Nam, X, It);
3599       end if;
3600
3601       while Present (It.Nam) loop
3602          if Etype (It.Nam) = Standard_Void_Type then
3603             Void_Interp_Seen := True;
3604          end if;
3605
3606          Analyze_One_Call (N, It.Nam, True, Success);
3607          Get_Next_Interp (X, It);
3608       end loop;
3609
3610       if Nkind (N) = N_Function_Call then
3611          Get_First_Interp (Nam, X, It);
3612          while Present (It.Nam) loop
3613             if Ekind (It.Nam) = E_Function
3614               or else Ekind (It.Nam) = E_Operator
3615             then
3616                return;
3617             else
3618                Get_Next_Interp (X, It);
3619             end if;
3620          end loop;
3621
3622          --  If all interpretations are procedures, this deserves a
3623          --  more precise message. Ditto if this appears as the prefix
3624          --  of a selected component, which may be a lexical error.
3625
3626          Error_Msg_N
3627            ("\context requires function call, found procedure name", Nam);
3628
3629          if Nkind (Parent (N)) = N_Selected_Component
3630            and then N = Prefix (Parent (N))
3631          then
3632             Error_Msg_N (
3633               "\period should probably be semicolon", Parent (N));
3634          end if;
3635
3636       elsif Nkind (N) = N_Procedure_Call_Statement
3637         and then not Void_Interp_Seen
3638       then
3639          Error_Msg_N (
3640          "\function name found in procedure call", Nam);
3641       end if;
3642
3643       All_Errors_Mode := Err_Mode;
3644    end Diagnose_Call;
3645
3646    ---------------------------
3647    -- Find_Arithmetic_Types --
3648    ---------------------------
3649
3650    procedure Find_Arithmetic_Types
3651      (L, R  : Node_Id;
3652       Op_Id : Entity_Id;
3653       N     : Node_Id)
3654    is
3655       Index1 : Interp_Index;
3656       Index2 : Interp_Index;
3657       It1    : Interp;
3658       It2    : Interp;
3659
3660       procedure Check_Right_Argument (T : Entity_Id);
3661       --  Check right operand of operator
3662
3663       --------------------------
3664       -- Check_Right_Argument --
3665       --------------------------
3666
3667       procedure Check_Right_Argument (T : Entity_Id) is
3668       begin
3669          if not Is_Overloaded (R) then
3670             Check_Arithmetic_Pair (T, Etype (R), Op_Id,  N);
3671          else
3672             Get_First_Interp (R, Index2, It2);
3673             while Present (It2.Typ) loop
3674                Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
3675                Get_Next_Interp (Index2, It2);
3676             end loop;
3677          end if;
3678       end Check_Right_Argument;
3679
3680    --  Start processing for Find_Arithmetic_Types
3681
3682    begin
3683       if not Is_Overloaded (L) then
3684          Check_Right_Argument (Etype (L));
3685
3686       else
3687          Get_First_Interp (L, Index1, It1);
3688
3689          while Present (It1.Typ) loop
3690             Check_Right_Argument (It1.Typ);
3691             Get_Next_Interp (Index1, It1);
3692          end loop;
3693       end if;
3694
3695    end Find_Arithmetic_Types;
3696
3697    ------------------------
3698    -- Find_Boolean_Types --
3699    ------------------------
3700
3701    procedure Find_Boolean_Types
3702      (L, R  : Node_Id;
3703       Op_Id : Entity_Id;
3704       N     : Node_Id)
3705    is
3706       Index : Interp_Index;
3707       It    : Interp;
3708
3709       procedure Check_Numeric_Argument (T : Entity_Id);
3710       --  Special case for logical operations one of whose operands is an
3711       --  integer literal. If both are literal the result is any modular type.
3712
3713       ----------------------------
3714       -- Check_Numeric_Argument --
3715       ----------------------------
3716
3717       procedure Check_Numeric_Argument (T : Entity_Id) is
3718       begin
3719          if T = Universal_Integer then
3720             Add_One_Interp (N, Op_Id, Any_Modular);
3721
3722          elsif Is_Modular_Integer_Type (T) then
3723             Add_One_Interp (N, Op_Id, T);
3724          end if;
3725       end Check_Numeric_Argument;
3726
3727    --  Start of processing for Find_Boolean_Types
3728
3729    begin
3730       if not Is_Overloaded (L) then
3731          if Etype (L) = Universal_Integer
3732            or else Etype (L) = Any_Modular
3733          then
3734             if not Is_Overloaded (R) then
3735                Check_Numeric_Argument (Etype (R));
3736
3737             else
3738                Get_First_Interp (R, Index, It);
3739                while Present (It.Typ) loop
3740                   Check_Numeric_Argument (It.Typ);
3741                   Get_Next_Interp (Index, It);
3742                end loop;
3743             end if;
3744
3745          elsif Valid_Boolean_Arg (Etype (L))
3746            and then Has_Compatible_Type (R, Etype (L))
3747          then
3748             Add_One_Interp (N, Op_Id, Etype (L));
3749          end if;
3750
3751       else
3752          Get_First_Interp (L, Index, It);
3753          while Present (It.Typ) loop
3754             if Valid_Boolean_Arg (It.Typ)
3755               and then Has_Compatible_Type (R, It.Typ)
3756             then
3757                Add_One_Interp (N, Op_Id, It.Typ);
3758             end if;
3759
3760             Get_Next_Interp (Index, It);
3761          end loop;
3762       end if;
3763    end Find_Boolean_Types;
3764
3765    ---------------------------
3766    -- Find_Comparison_Types --
3767    ---------------------------
3768
3769    procedure Find_Comparison_Types
3770      (L, R  : Node_Id;
3771       Op_Id : Entity_Id;
3772       N     : Node_Id)
3773    is
3774       Index : Interp_Index;
3775       It    : Interp;
3776       Found : Boolean := False;
3777       I_F   : Interp_Index;
3778       T_F   : Entity_Id;
3779       Scop  : Entity_Id := Empty;
3780
3781       procedure Try_One_Interp (T1 : Entity_Id);
3782       --  Routine to try one proposed interpretation. Note that the context
3783       --  of the operator plays no role in resolving the arguments, so that
3784       --  if there is more than one interpretation of the operands that is
3785       --  compatible with comparison, the operation is ambiguous.
3786
3787       --------------------
3788       -- Try_One_Interp --
3789       --------------------
3790
3791       procedure Try_One_Interp (T1 : Entity_Id) is
3792       begin
3793
3794          --  If the operator is an expanded name, then the type of the operand
3795          --  must be defined in the corresponding scope. If the type is
3796          --  universal, the context will impose the correct type.
3797
3798          if Present (Scop)
3799             and then not Defined_In_Scope (T1, Scop)
3800             and then T1 /= Universal_Integer
3801             and then T1 /= Universal_Real
3802             and then T1 /= Any_String
3803             and then T1 /= Any_Composite
3804          then
3805             return;
3806          end if;
3807
3808          if Valid_Comparison_Arg (T1)
3809            and then Has_Compatible_Type (R, T1)
3810          then
3811             if Found
3812               and then Base_Type (T1) /= Base_Type (T_F)
3813             then
3814                It := Disambiguate (L, I_F, Index, Any_Type);
3815
3816                if It = No_Interp then
3817                   Ambiguous_Operands (N);
3818                   Set_Etype (L, Any_Type);
3819                   return;
3820
3821                else
3822                   T_F := It.Typ;
3823                end if;
3824
3825             else
3826                Found := True;
3827                T_F   := T1;
3828                I_F   := Index;
3829             end if;
3830
3831             Set_Etype (L, T_F);
3832             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
3833
3834          end if;
3835       end Try_One_Interp;
3836
3837    --  Start processing for Find_Comparison_Types
3838
3839    begin
3840       --  If left operand is aggregate, the right operand has to
3841       --  provide a usable type for it.
3842
3843       if Nkind (L) = N_Aggregate
3844         and then Nkind (R) /= N_Aggregate
3845       then
3846          Find_Comparison_Types (R, L, Op_Id, N);
3847          return;
3848       end if;
3849
3850       if Nkind (N) = N_Function_Call
3851          and then Nkind (Name (N)) = N_Expanded_Name
3852       then
3853          Scop := Entity (Prefix (Name (N)));
3854
3855          --  The prefix may be a package renaming, and the subsequent test
3856          --  requires the original package.
3857
3858          if Ekind (Scop) = E_Package
3859            and then Present (Renamed_Entity (Scop))
3860          then
3861             Scop := Renamed_Entity (Scop);
3862             Set_Entity (Prefix (Name (N)), Scop);
3863          end if;
3864       end if;
3865
3866       if not Is_Overloaded (L) then
3867          Try_One_Interp (Etype (L));
3868
3869       else
3870          Get_First_Interp (L, Index, It);
3871          while Present (It.Typ) loop
3872             Try_One_Interp (It.Typ);
3873             Get_Next_Interp (Index, It);
3874          end loop;
3875       end if;
3876    end Find_Comparison_Types;
3877
3878    ----------------------------------------
3879    -- Find_Non_Universal_Interpretations --
3880    ----------------------------------------
3881
3882    procedure Find_Non_Universal_Interpretations
3883      (N     : Node_Id;
3884       R     : Node_Id;
3885       Op_Id : Entity_Id;
3886       T1    : Entity_Id)
3887    is
3888       Index : Interp_Index;
3889       It    : Interp;
3890
3891    begin
3892       if T1 = Universal_Integer
3893         or else T1 = Universal_Real
3894       then
3895          if not Is_Overloaded (R) then
3896             Add_One_Interp
3897               (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
3898          else
3899             Get_First_Interp (R, Index, It);
3900             while Present (It.Typ) loop
3901                if Covers (It.Typ, T1) then
3902                   Add_One_Interp
3903                     (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
3904                end if;
3905
3906                Get_Next_Interp (Index, It);
3907             end loop;
3908          end if;
3909       else
3910          Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
3911       end if;
3912    end Find_Non_Universal_Interpretations;
3913
3914    ------------------------------
3915    -- Find_Concatenation_Types --
3916    ------------------------------
3917
3918    procedure Find_Concatenation_Types
3919      (L, R  : Node_Id;
3920       Op_Id : Entity_Id;
3921       N     : Node_Id)
3922    is
3923       Op_Type : constant Entity_Id := Etype (Op_Id);
3924
3925    begin
3926       if Is_Array_Type (Op_Type)
3927         and then not Is_Limited_Type (Op_Type)
3928
3929         and then (Has_Compatible_Type (L, Op_Type)
3930                     or else
3931                   Has_Compatible_Type (L, Component_Type (Op_Type)))
3932
3933         and then (Has_Compatible_Type (R, Op_Type)
3934                     or else
3935                   Has_Compatible_Type (R, Component_Type (Op_Type)))
3936       then
3937          Add_One_Interp (N, Op_Id, Op_Type);
3938       end if;
3939    end Find_Concatenation_Types;
3940
3941    -------------------------
3942    -- Find_Equality_Types --
3943    -------------------------
3944
3945    procedure Find_Equality_Types
3946      (L, R  : Node_Id;
3947       Op_Id : Entity_Id;
3948       N     : Node_Id)
3949    is
3950       Index : Interp_Index;
3951       It    : Interp;
3952       Found : Boolean := False;
3953       I_F   : Interp_Index;
3954       T_F   : Entity_Id;
3955       Scop  : Entity_Id := Empty;
3956
3957       procedure Try_One_Interp (T1 : Entity_Id);
3958       --  The context of the operator plays no role in resolving the
3959       --  arguments,  so that if there is more than one interpretation
3960       --  of the operands that is compatible with equality, the construct
3961       --  is ambiguous and an error can be emitted now, after trying to
3962       --  disambiguate, i.e. applying preference rules.
3963
3964       --------------------
3965       -- Try_One_Interp --
3966       --------------------
3967
3968       procedure Try_One_Interp (T1 : Entity_Id) is
3969       begin
3970          --  If the operator is an expanded name, then the type of the operand
3971          --  must be defined in the corresponding scope. If the type is
3972          --  universal, the context will impose the correct type. An anonymous
3973          --  type for a 'Access reference is also universal in this sense, as
3974          --  the actual type is obtained from context.
3975
3976          if Present (Scop)
3977             and then not Defined_In_Scope (T1, Scop)
3978             and then T1 /= Universal_Integer
3979             and then T1 /= Universal_Real
3980             and then T1 /= Any_Access
3981             and then T1 /= Any_String
3982             and then T1 /= Any_Composite
3983             and then (Ekind (T1) /= E_Access_Subprogram_Type
3984                         or else Comes_From_Source (T1))
3985          then
3986             return;
3987          end if;
3988
3989          --  Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
3990          --  Do not allow anonymous access types in equality operators.
3991
3992          if Ada_Version < Ada_05
3993            and then Ekind (T1) = E_Anonymous_Access_Type
3994          then
3995             return;
3996          end if;
3997
3998          if T1 /= Standard_Void_Type
3999            and then not Is_Limited_Type (T1)
4000            and then not Is_Limited_Composite (T1)
4001            and then Has_Compatible_Type (R, T1)
4002          then
4003             if Found
4004               and then Base_Type (T1) /= Base_Type (T_F)
4005             then
4006                It := Disambiguate (L, I_F, Index, Any_Type);
4007
4008                if It = No_Interp then
4009                   Ambiguous_Operands (N);
4010                   Set_Etype (L, Any_Type);
4011                   return;
4012
4013                else
4014                   T_F := It.Typ;
4015                end if;
4016
4017             else
4018                Found := True;
4019                T_F   := T1;
4020                I_F   := Index;
4021             end if;
4022
4023             if not Analyzed (L) then
4024                Set_Etype (L, T_F);
4025             end if;
4026
4027             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4028
4029             --  Case of operator was not visible, Etype still set to Any_Type
4030
4031             if Etype (N) = Any_Type then
4032                Found := False;
4033             end if;
4034          end if;
4035       end Try_One_Interp;
4036
4037    --  Start of processing for Find_Equality_Types
4038
4039    begin
4040       --  If left operand is aggregate, the right operand has to
4041       --  provide a usable type for it.
4042
4043       if Nkind (L) = N_Aggregate
4044         and then Nkind (R) /= N_Aggregate
4045       then
4046          Find_Equality_Types (R, L, Op_Id, N);
4047          return;
4048       end if;
4049
4050       if Nkind (N) = N_Function_Call
4051          and then Nkind (Name (N)) = N_Expanded_Name
4052       then
4053          Scop := Entity (Prefix (Name (N)));
4054
4055          --  The prefix may be a package renaming, and the subsequent test
4056          --  requires the original package.
4057
4058          if Ekind (Scop) = E_Package
4059            and then Present (Renamed_Entity (Scop))
4060          then
4061             Scop := Renamed_Entity (Scop);
4062             Set_Entity (Prefix (Name (N)), Scop);
4063          end if;
4064       end if;
4065
4066       if not Is_Overloaded (L) then
4067          Try_One_Interp (Etype (L));
4068
4069       else
4070          Get_First_Interp (L, Index, It);
4071          while Present (It.Typ) loop
4072             Try_One_Interp (It.Typ);
4073             Get_Next_Interp (Index, It);
4074          end loop;
4075       end if;
4076    end Find_Equality_Types;
4077
4078    -------------------------
4079    -- Find_Negation_Types --
4080    -------------------------
4081
4082    procedure Find_Negation_Types
4083      (R     : Node_Id;
4084       Op_Id : Entity_Id;
4085       N     : Node_Id)
4086    is
4087       Index : Interp_Index;
4088       It    : Interp;
4089
4090    begin
4091       if not Is_Overloaded (R) then
4092          if Etype (R) = Universal_Integer then
4093             Add_One_Interp (N, Op_Id, Any_Modular);
4094          elsif Valid_Boolean_Arg (Etype (R)) then
4095             Add_One_Interp (N, Op_Id, Etype (R));
4096          end if;
4097
4098       else
4099          Get_First_Interp (R, Index, It);
4100          while Present (It.Typ) loop
4101             if Valid_Boolean_Arg (It.Typ) then
4102                Add_One_Interp (N, Op_Id, It.Typ);
4103             end if;
4104
4105             Get_Next_Interp (Index, It);
4106          end loop;
4107       end if;
4108    end Find_Negation_Types;
4109
4110    ----------------------
4111    -- Find_Unary_Types --
4112    ----------------------
4113
4114    procedure Find_Unary_Types
4115      (R     : Node_Id;
4116       Op_Id : Entity_Id;
4117       N     : Node_Id)
4118    is
4119       Index : Interp_Index;
4120       It    : Interp;
4121
4122    begin
4123       if not Is_Overloaded (R) then
4124          if Is_Numeric_Type (Etype (R)) then
4125             Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
4126          end if;
4127
4128       else
4129          Get_First_Interp (R, Index, It);
4130          while Present (It.Typ) loop
4131             if Is_Numeric_Type (It.Typ) then
4132                Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
4133             end if;
4134
4135             Get_Next_Interp (Index, It);
4136          end loop;
4137       end if;
4138    end Find_Unary_Types;
4139
4140    ------------------
4141    -- Junk_Operand --
4142    ------------------
4143
4144    function Junk_Operand (N : Node_Id) return Boolean is
4145       Enode : Node_Id;
4146
4147    begin
4148       if Error_Posted (N) then
4149          return False;
4150       end if;
4151
4152       --  Get entity to be tested
4153
4154       if Is_Entity_Name (N)
4155         and then Present (Entity (N))
4156       then
4157          Enode := N;
4158
4159       --  An odd case, a procedure name gets converted to a very peculiar
4160       --  function call, and here is where we detect this happening.
4161
4162       elsif Nkind (N) = N_Function_Call
4163         and then Is_Entity_Name (Name (N))
4164         and then Present (Entity (Name (N)))
4165       then
4166          Enode := Name (N);
4167
4168       --  Another odd case, there are at least some cases of selected
4169       --  components where the selected component is not marked as having
4170       --  an entity, even though the selector does have an entity
4171
4172       elsif Nkind (N) = N_Selected_Component
4173         and then Present (Entity (Selector_Name (N)))
4174       then
4175          Enode := Selector_Name (N);
4176
4177       else
4178          return False;
4179       end if;
4180
4181       --  Now test the entity we got to see if it a bad case
4182
4183       case Ekind (Entity (Enode)) is
4184
4185          when E_Package =>
4186             Error_Msg_N
4187               ("package name cannot be used as operand", Enode);
4188
4189          when Generic_Unit_Kind =>
4190             Error_Msg_N
4191               ("generic unit name cannot be used as operand", Enode);
4192
4193          when Type_Kind =>
4194             Error_Msg_N
4195               ("subtype name cannot be used as operand", Enode);
4196
4197          when Entry_Kind =>
4198             Error_Msg_N
4199               ("entry name cannot be used as operand", Enode);
4200
4201          when E_Procedure =>
4202             Error_Msg_N
4203               ("procedure name cannot be used as operand", Enode);
4204
4205          when E_Exception =>
4206             Error_Msg_N
4207               ("exception name cannot be used as operand", Enode);
4208
4209          when E_Block | E_Label | E_Loop =>
4210             Error_Msg_N
4211               ("label name cannot be used as operand", Enode);
4212
4213          when others =>
4214             return False;
4215
4216       end case;
4217
4218       return True;
4219    end Junk_Operand;
4220
4221    --------------------
4222    -- Operator_Check --
4223    --------------------
4224
4225    procedure Operator_Check (N : Node_Id) is
4226    begin
4227       Remove_Abstract_Operations (N);
4228
4229       --  Test for case of no interpretation found for operator
4230
4231       if Etype (N) = Any_Type then
4232          declare
4233             L : Node_Id;
4234             R : Node_Id;
4235
4236          begin
4237             R := Right_Opnd (N);
4238
4239             if Nkind (N) in N_Binary_Op then
4240                L := Left_Opnd (N);
4241             else
4242                L := Empty;
4243             end if;
4244
4245             --  If either operand has no type, then don't complain further,
4246             --  since this simply means that we have a propragated error.
4247
4248             if R = Error
4249               or else Etype (R) = Any_Type
4250               or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
4251             then
4252                return;
4253
4254             --  We explicitly check for the case of concatenation of component
4255             --  with component to avoid reporting spurious matching array types
4256             --  that might happen to be lurking in distant packages (such as
4257             --  run-time packages). This also prevents inconsistencies in the
4258             --  messages for certain ACVC B tests, which can vary depending on
4259             --  types declared in run-time interfaces. Another improvement when
4260             --  aggregates are present is to look for a well-typed operand.
4261
4262             elsif Present (Candidate_Type)
4263               and then (Nkind (N) /= N_Op_Concat
4264                          or else Is_Array_Type (Etype (L))
4265                          or else Is_Array_Type (Etype (R)))
4266             then
4267
4268                if Nkind (N) = N_Op_Concat then
4269                   if Etype (L) /= Any_Composite
4270                     and then Is_Array_Type (Etype (L))
4271                   then
4272                      Candidate_Type := Etype (L);
4273
4274                   elsif Etype (R) /= Any_Composite
4275                     and then Is_Array_Type (Etype (R))
4276                   then
4277                      Candidate_Type := Etype (R);
4278                   end if;
4279                end if;
4280
4281                Error_Msg_NE
4282                  ("operator for} is not directly visible!",
4283                   N, First_Subtype (Candidate_Type));
4284                Error_Msg_N ("use clause would make operation legal!",  N);
4285                return;
4286
4287             --  If either operand is a junk operand (e.g. package name), then
4288             --  post appropriate error messages, but do not complain further.
4289
4290             --  Note that the use of OR in this test instead of OR ELSE
4291             --  is quite deliberate, we may as well check both operands
4292             --  in the binary operator case.
4293
4294             elsif Junk_Operand (R)
4295               or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
4296             then
4297                return;
4298
4299             --  If we have a logical operator, one of whose operands is
4300             --  Boolean, then we know that the other operand cannot resolve
4301             --  to Boolean (since we got no interpretations), but in that
4302             --  case we pretty much know that the other operand should be
4303             --  Boolean, so resolve it that way (generating an error)
4304
4305             elsif Nkind (N) = N_Op_And
4306                     or else
4307                   Nkind (N) = N_Op_Or
4308                     or else
4309                   Nkind (N) = N_Op_Xor
4310             then
4311                if Etype (L) = Standard_Boolean then
4312                   Resolve (R, Standard_Boolean);
4313                   return;
4314                elsif Etype (R) = Standard_Boolean then
4315                   Resolve (L, Standard_Boolean);
4316                   return;
4317                end if;
4318
4319             --  For an arithmetic operator or comparison operator, if one
4320             --  of the operands is numeric, then we know the other operand
4321             --  is not the same numeric type. If it is a non-numeric type,
4322             --  then probably it is intended to match the other operand.
4323
4324             elsif Nkind (N) = N_Op_Add      or else
4325                   Nkind (N) = N_Op_Divide   or else
4326                   Nkind (N) = N_Op_Ge       or else
4327                   Nkind (N) = N_Op_Gt       or else
4328                   Nkind (N) = N_Op_Le       or else
4329                   Nkind (N) = N_Op_Lt       or else
4330                   Nkind (N) = N_Op_Mod      or else
4331                   Nkind (N) = N_Op_Multiply or else
4332                   Nkind (N) = N_Op_Rem      or else
4333                   Nkind (N) = N_Op_Subtract
4334             then
4335                if Is_Numeric_Type (Etype (L))
4336                  and then not Is_Numeric_Type (Etype (R))
4337                then
4338                   Resolve (R, Etype (L));
4339                   return;
4340
4341                elsif Is_Numeric_Type (Etype (R))
4342                  and then not Is_Numeric_Type (Etype (L))
4343                then
4344                   Resolve (L, Etype (R));
4345                   return;
4346                end if;
4347
4348             --  Comparisons on A'Access are common enough to deserve a
4349             --  special message.
4350
4351             elsif (Nkind (N) = N_Op_Eq  or else
4352                    Nkind (N) = N_Op_Ne)
4353                and then Ekind (Etype (L)) = E_Access_Attribute_Type
4354                and then Ekind (Etype (R)) = E_Access_Attribute_Type
4355             then
4356                Error_Msg_N
4357                  ("two access attributes cannot be compared directly", N);
4358                Error_Msg_N
4359                  ("\they must be converted to an explicit type for comparison",
4360                    N);
4361                return;
4362
4363             --  Another one for C programmers
4364
4365             elsif Nkind (N) = N_Op_Concat
4366               and then Valid_Boolean_Arg (Etype (L))
4367               and then Valid_Boolean_Arg (Etype (R))
4368             then
4369                Error_Msg_N ("invalid operands for concatenation", N);
4370                Error_Msg_N ("\maybe AND was meant", N);
4371                return;
4372
4373             --  A special case for comparison of access parameter with null
4374
4375             elsif Nkind (N) = N_Op_Eq
4376               and then Is_Entity_Name (L)
4377               and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
4378               and then Nkind (Parameter_Type (Parent (Entity (L)))) =
4379                                                   N_Access_Definition
4380               and then Nkind (R) = N_Null
4381             then
4382                Error_Msg_N ("access parameter is not allowed to be null", L);
4383                Error_Msg_N ("\(call would raise Constraint_Error)", L);
4384                return;
4385             end if;
4386
4387             --  If we fall through then just give general message. Note
4388             --  that in the following messages, if the operand is overloaded
4389             --  we choose an arbitrary type to complain about, but that is
4390             --  probably more useful than not giving a type at all.
4391
4392             if Nkind (N) in N_Unary_Op then
4393                Error_Msg_Node_2 := Etype (R);
4394                Error_Msg_N ("operator& not defined for}", N);
4395                return;
4396
4397             else
4398                if Nkind (N) in N_Binary_Op then
4399                   if not Is_Overloaded (L)
4400                     and then not Is_Overloaded (R)
4401                     and then Base_Type (Etype (L)) = Base_Type (Etype (R))
4402                   then
4403                      Error_Msg_Node_2 := Etype (R);
4404                      Error_Msg_N ("there is no applicable operator& for}", N);
4405
4406                   else
4407                      Error_Msg_N ("invalid operand types for operator&", N);
4408
4409                      if Nkind (N) /= N_Op_Concat then
4410                         Error_Msg_NE ("\left operand has}!",  N, Etype (L));
4411                         Error_Msg_NE ("\right operand has}!", N, Etype (R));
4412                      end if;
4413                   end if;
4414                end if;
4415             end if;
4416          end;
4417       end if;
4418    end Operator_Check;
4419
4420    -----------------------------------------
4421    -- Process_Implicit_Dereference_Prefix --
4422    -----------------------------------------
4423
4424    procedure Process_Implicit_Dereference_Prefix
4425      (E : Entity_Id;
4426       P : Entity_Id)
4427    is
4428       Ref : Node_Id;
4429
4430    begin
4431       if Operating_Mode = Check_Semantics and then Present (E) then
4432
4433          --  We create a dummy reference to E to ensure that the reference
4434          --  is not considered as part of an assignment (an implicit
4435          --  dereference can never assign to its prefix). The Comes_From_Source
4436          --  attribute needs to be propagated for accurate warnings.
4437
4438          Ref := New_Reference_To (E, Sloc (P));
4439          Set_Comes_From_Source (Ref, Comes_From_Source (P));
4440          Generate_Reference (E, Ref);
4441       end if;
4442    end Process_Implicit_Dereference_Prefix;
4443
4444    --------------------------------
4445    -- Remove_Abstract_Operations --
4446    --------------------------------
4447
4448    procedure Remove_Abstract_Operations (N : Node_Id) is
4449       I            : Interp_Index;
4450       It           : Interp;
4451       Abstract_Op  : Entity_Id := Empty;
4452
4453       --  AI-310: If overloaded, remove abstract non-dispatching
4454       --  operations. We activate this if either extensions are
4455       --  enabled, or if the abstract operation in question comes
4456       --  from a predefined file. This latter test allows us to
4457       --  use abstract to make operations invisible to users. In
4458       --  particular, if type Address is non-private and abstract
4459       --  subprograms are used to hide its operators, they will be
4460       --  truly hidden.
4461
4462       type Operand_Position is (First_Op, Second_Op);
4463       Univ_Type : constant Entity_Id := Universal_Interpretation (N);
4464
4465       procedure Remove_Address_Interpretations (Op : Operand_Position);
4466       --  Ambiguities may arise when the operands are literal and the
4467       --  address operations in s-auxdec are visible. In that case, remove
4468       --  the interpretation of a literal as Address, to retain the semantics
4469       --  of Address as a private type.
4470
4471       ------------------------------------
4472       -- Remove_Address_Interpretations --
4473       ------------------------------------
4474
4475       procedure Remove_Address_Interpretations (Op : Operand_Position) is
4476          Formal : Entity_Id;
4477
4478       begin
4479          if Is_Overloaded (N) then
4480             Get_First_Interp (N, I, It);
4481             while Present (It.Nam) loop
4482                Formal := First_Entity (It.Nam);
4483
4484                if Op = Second_Op then
4485                   Formal := Next_Entity (Formal);
4486                end if;
4487
4488                if Is_Descendent_Of_Address (Etype (Formal)) then
4489                   Remove_Interp (I);
4490                end if;
4491
4492                Get_Next_Interp (I, It);
4493             end loop;
4494          end if;
4495       end Remove_Address_Interpretations;
4496
4497    --  Start of processing for Remove_Abstract_Operations
4498
4499    begin
4500       if Is_Overloaded (N) then
4501          Get_First_Interp (N, I, It);
4502
4503          while Present (It.Nam) loop
4504             if not Is_Type (It.Nam)
4505               and then Is_Abstract (It.Nam)
4506               and then not Is_Dispatching_Operation (It.Nam)
4507               and then
4508                 (Ada_Version >= Ada_05
4509                    or else Is_Predefined_File_Name
4510                              (Unit_File_Name (Get_Source_Unit (It.Nam))))
4511
4512             then
4513                Abstract_Op := It.Nam;
4514                Remove_Interp (I);
4515                exit;
4516             end if;
4517
4518             Get_Next_Interp (I, It);
4519          end loop;
4520
4521          if No (Abstract_Op) then
4522             return;
4523
4524          elsif Nkind (N) in N_Op then
4525
4526             --  Remove interpretations that treat literals as addresses.
4527             --  This is never appropriate.
4528
4529             if Nkind (N) in N_Binary_Op then
4530                declare
4531                   U1 : constant Boolean :=
4532                      Present (Universal_Interpretation (Right_Opnd (N)));
4533                   U2 : constant Boolean :=
4534                      Present (Universal_Interpretation (Left_Opnd (N)));
4535
4536                begin
4537                   if U1 and then not U2 then
4538                      Remove_Address_Interpretations (Second_Op);
4539
4540                   elsif U2 and then not U1 then
4541                      Remove_Address_Interpretations (First_Op);
4542                   end if;
4543
4544                   if not (U1 and U2) then
4545
4546                      --  Remove corresponding predefined operator, which is
4547                      --  always added to the overload set.
4548
4549                      Get_First_Interp (N, I, It);
4550                      while Present (It.Nam) loop
4551                         if Scope (It.Nam) = Standard_Standard
4552                           and then Base_Type (It.Typ) =
4553                                    Base_Type (Etype (Abstract_Op))
4554                         then
4555                            Remove_Interp (I);
4556                         end if;
4557
4558                         Get_Next_Interp (I, It);
4559                      end loop;
4560
4561                   elsif Is_Overloaded (N)
4562                     and then Present (Univ_Type)
4563                   then
4564                      --  If both operands have a universal interpretation,
4565                      --  select the predefined operator and discard others.
4566
4567                      Get_First_Interp (N, I, It);
4568
4569                      while Present (It.Nam) loop
4570                         if Scope (It.Nam) = Standard_Standard then
4571                            Set_Etype (N, Univ_Type);
4572                            Set_Entity (N, It.Nam);
4573                            Set_Is_Overloaded (N, False);
4574                            exit;
4575                         end if;
4576
4577                         Get_Next_Interp (I, It);
4578                      end loop;
4579                   end if;
4580                end;
4581             end if;
4582
4583          elsif Nkind (N) = N_Function_Call
4584            and then
4585              (Nkind (Name (N)) = N_Operator_Symbol
4586                 or else
4587                   (Nkind (Name (N)) = N_Expanded_Name
4588                      and then
4589                        Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
4590          then
4591
4592             declare
4593                Arg1 : constant Node_Id := First (Parameter_Associations (N));
4594                U1   : constant Boolean :=
4595                         Present (Universal_Interpretation (Arg1));
4596                U2   : constant Boolean :=
4597                         Present (Next (Arg1)) and then
4598                         Present (Universal_Interpretation (Next (Arg1)));
4599
4600             begin
4601                if U1 and then not U2 then
4602                   Remove_Address_Interpretations (First_Op);
4603
4604                elsif U2 and then not U1 then
4605                   Remove_Address_Interpretations (Second_Op);
4606                end if;
4607
4608                if not (U1 and U2) then
4609                   Get_First_Interp (N, I, It);
4610                   while Present (It.Nam) loop
4611                      if Scope (It.Nam) = Standard_Standard
4612                        and then It.Typ = Base_Type (Etype (Abstract_Op))
4613                      then
4614                         Remove_Interp (I);
4615                      end if;
4616
4617                      Get_Next_Interp (I, It);
4618                   end loop;
4619                end if;
4620             end;
4621          end if;
4622
4623          --  If the removal has left no valid interpretations, emit
4624          --  error message now and label node as illegal.
4625
4626          if Present (Abstract_Op) then
4627             Get_First_Interp (N, I, It);
4628
4629             if No (It.Nam) then
4630
4631                --  Removal of abstract operation left no viable candidate
4632
4633                Set_Etype (N, Any_Type);
4634                Error_Msg_Sloc := Sloc (Abstract_Op);
4635                Error_Msg_NE
4636                  ("cannot call abstract operation& declared#", N, Abstract_Op);
4637             end if;
4638          end if;
4639       end if;
4640    end Remove_Abstract_Operations;
4641
4642    -----------------------
4643    -- Try_Indirect_Call --
4644    -----------------------
4645
4646    function Try_Indirect_Call
4647      (N   : Node_Id;
4648       Nam : Entity_Id;
4649       Typ : Entity_Id) return Boolean
4650    is
4651       Actual  : Node_Id;
4652       Formal  : Entity_Id;
4653       Call_OK : Boolean;
4654
4655    begin
4656       Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK);
4657       Actual := First_Actual (N);
4658       Formal := First_Formal (Designated_Type (Typ));
4659
4660       while Present (Actual)
4661         and then Present (Formal)
4662       loop
4663          if not Has_Compatible_Type (Actual, Etype (Formal)) then
4664             return False;
4665          end if;
4666
4667          Next (Actual);
4668          Next_Formal (Formal);
4669       end loop;
4670
4671       if No (Actual) and then No (Formal) then
4672          Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
4673
4674          --  Nam is a candidate interpretation for the name in the call,
4675          --  if it is not an indirect call.
4676
4677          if not Is_Type (Nam)
4678             and then Is_Entity_Name (Name (N))
4679          then
4680             Set_Entity (Name (N), Nam);
4681          end if;
4682
4683          return True;
4684       else
4685          return False;
4686       end if;
4687    end Try_Indirect_Call;
4688
4689    ----------------------
4690    -- Try_Indexed_Call --
4691    ----------------------
4692
4693    function Try_Indexed_Call
4694      (N   : Node_Id;
4695       Nam : Entity_Id;
4696       Typ : Entity_Id) return Boolean
4697    is
4698       Actuals : constant List_Id   := Parameter_Associations (N);
4699       Actual : Node_Id;
4700       Index  : Entity_Id;
4701
4702    begin
4703       Actual := First (Actuals);
4704       Index := First_Index (Typ);
4705       while Present (Actual)
4706         and then Present (Index)
4707       loop
4708          --  If the parameter list has a named association, the expression
4709          --  is definitely a call and not an indexed component.
4710
4711          if Nkind (Actual) = N_Parameter_Association then
4712             return False;
4713          end if;
4714
4715          if not Has_Compatible_Type (Actual, Etype (Index)) then
4716             return False;
4717          end if;
4718
4719          Next (Actual);
4720          Next_Index (Index);
4721       end loop;
4722
4723       if No (Actual) and then No (Index) then
4724          Add_One_Interp (N, Nam, Component_Type (Typ));
4725
4726          --  Nam is a candidate interpretation for the name in the call,
4727          --  if it is not an indirect call.
4728
4729          if not Is_Type (Nam)
4730             and then Is_Entity_Name (Name (N))
4731          then
4732             Set_Entity (Name (N), Nam);
4733          end if;
4734
4735          return True;
4736       else
4737          return False;
4738       end if;
4739    end Try_Indexed_Call;
4740
4741    --------------------------
4742    -- Try_Object_Operation --
4743    --------------------------
4744
4745    function Try_Object_Operation (N : Node_Id) return Boolean is
4746       K               : constant Node_Kind  := Nkind (Parent (N));
4747       Loc             : constant Source_Ptr := Sloc (N);
4748       Is_Subprg_Call  : constant Boolean    := K = N_Procedure_Call_Statement
4749                                                 or else K = N_Function_Call;
4750       Obj             : constant Node_Id    := Prefix (N);
4751       Subprog         : constant Node_Id    := Selector_Name (N);
4752
4753       Actual          : Node_Id;
4754       Call_Node       : Node_Id;
4755       Call_Node_Case  : Node_Id := Empty;
4756       First_Actual    : Node_Id;
4757       Node_To_Replace : Node_Id;
4758       Obj_Type        : Entity_Id := Etype (Obj);
4759
4760       procedure Complete_Object_Operation
4761         (Call_Node       : Node_Id;
4762          Node_To_Replace : Node_Id;
4763          Subprog         : Node_Id);
4764       --  Set Subprog as the name of Call_Node, replace Node_To_Replace with
4765       --  Call_Node and reanalyze Node_To_Replace.
4766
4767       procedure Transform_Object_Operation
4768         (Call_Node       : out Node_Id;
4769          First_Actual    : Node_Id;
4770          Node_To_Replace : out Node_Id;
4771          Subprog         : Node_Id);
4772       --  Transform Object.Operation (...) to Operation (Object, ...)
4773       --  Call_Node is the resulting subprogram call node, First_Actual is
4774       --  either the object Obj or an explicit dereference of Obj in certain
4775       --  cases, Node_To_Replace is either N or the parent of N, and Subprog
4776       --  is the subprogram we are trying to match.
4777
4778       function Try_Class_Wide_Operation
4779         (Call_Node       : Node_Id;
4780          Node_To_Replace : Node_Id) return Boolean;
4781       --  Traverse all the ancestor types looking for a class-wide subprogram
4782       --  that matches Subprog.
4783
4784       function Try_Primitive_Operation
4785         (Call_Node       : Node_Id;
4786          Node_To_Replace : Node_Id) return Boolean;
4787       --  Traverse the list of primitive subprograms looking for a subprogram
4788       --  than matches Subprog.
4789
4790       -------------------------------
4791       -- Complete_Object_Operation --
4792       -------------------------------
4793
4794       procedure Complete_Object_Operation
4795         (Call_Node       : Node_Id;
4796          Node_To_Replace : Node_Id;
4797          Subprog         : Node_Id)
4798       is
4799       begin
4800          Set_Name (Call_Node, New_Copy_Tree (Subprog));
4801          Set_Analyzed (Call_Node, False);
4802          Replace (Node_To_Replace, Call_Node);
4803          Analyze (Node_To_Replace);
4804
4805       end Complete_Object_Operation;
4806
4807       --------------------------------
4808       -- Transform_Object_Operation --
4809       --------------------------------
4810
4811       procedure Transform_Object_Operation
4812         (Call_Node       : out Node_Id;
4813          First_Actual    : Node_Id;
4814          Node_To_Replace : out Node_Id;
4815          Subprog         : Node_Id)
4816       is
4817          Actuals     : List_Id;
4818          Parent_Node : constant Node_Id := Parent (N);
4819
4820       begin
4821          Actuals := New_List (New_Copy_Tree (First_Actual));
4822
4823          if (Nkind (Parent_Node) = N_Function_Call
4824                or else
4825              Nkind (Parent_Node) = N_Procedure_Call_Statement)
4826
4827             --  Avoid recursive calls
4828
4829            and then N /= First (Parameter_Associations (Parent_Node))
4830          then
4831             Node_To_Replace := Parent_Node;
4832
4833             Append_List_To (Actuals,
4834               New_Copy_List (Parameter_Associations (Parent_Node)));
4835
4836             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
4837                Call_Node :=
4838                  Make_Procedure_Call_Statement (Loc,
4839                    Name => New_Copy_Tree (Subprog),
4840                    Parameter_Associations => Actuals);
4841
4842             else
4843                pragma Assert (Nkind (Parent_Node) = N_Function_Call);
4844
4845                Call_Node :=
4846                  Make_Function_Call (Loc,
4847                    Name => New_Copy_Tree (Subprog),
4848                    Parameter_Associations => Actuals);
4849
4850             end if;
4851
4852          --  Parameterless call
4853
4854          else
4855             Node_To_Replace := N;
4856
4857             Call_Node :=
4858                Make_Function_Call (Loc,
4859                  Name => New_Copy_Tree (Subprog),
4860                  Parameter_Associations => Actuals);
4861
4862          end if;
4863       end Transform_Object_Operation;
4864
4865       ------------------------------
4866       -- Try_Class_Wide_Operation --
4867       ------------------------------
4868
4869       function Try_Class_Wide_Operation
4870         (Call_Node       : Node_Id;
4871          Node_To_Replace : Node_Id) return Boolean
4872       is
4873          Anc_Type : Entity_Id;
4874          Dummy    : Node_Id;
4875          Hom      : Entity_Id;
4876          Hom_Ref  : Node_Id;
4877          Success  : Boolean;
4878
4879       begin
4880          --  Loop through ancestor types, traverse their homonym chains and
4881          --  gather all interpretations of the subprogram.
4882
4883          Anc_Type := Obj_Type;
4884          loop
4885             Hom := Current_Entity (Subprog);
4886             while Present (Hom) loop
4887                if (Ekind (Hom) = E_Procedure
4888                      or else
4889                    Ekind (Hom) = E_Function)
4890                  and then Present (First_Formal (Hom))
4891                  and then Etype (First_Formal (Hom)) =
4892                             Class_Wide_Type (Anc_Type)
4893                then
4894                   Hom_Ref := New_Reference_To (Hom, Loc);
4895
4896                   --  When both the type of the object and the type of the
4897                   --  first formal of the primitive operation are tagged
4898                   --  access types, we use a node with the object as first
4899                   --  actual.
4900
4901                   if Is_Access_Type (Etype (Obj))
4902                     and then Ekind (Etype (First_Formal (Hom))) =
4903                                E_Anonymous_Access_Type
4904                   then
4905                      --  Allocate the node only once
4906
4907                      if not Present (Call_Node_Case) then
4908                         Transform_Object_Operation (
4909                           Call_Node       => Call_Node_Case,
4910                           First_Actual    => Obj,
4911                           Node_To_Replace => Dummy,
4912                           Subprog         => Subprog);
4913
4914                         Set_Etype (Call_Node_Case, Any_Type);
4915                         Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
4916                      end if;
4917
4918                      Set_Name (Call_Node_Case, Hom_Ref);
4919
4920                      Analyze_One_Call (
4921                        N       => Call_Node_Case,
4922                        Nam     => Hom,
4923                        Report  => False,
4924                        Success => Success);
4925
4926                      if Success then
4927                         Complete_Object_Operation (
4928                           Call_Node       => Call_Node_Case,
4929                           Node_To_Replace => Node_To_Replace,
4930                           Subprog         => Hom_Ref);
4931
4932                         return True;
4933                      end if;
4934
4935                   --  ??? comment required
4936
4937                   else
4938                      Set_Name (Call_Node, Hom_Ref);
4939
4940                      Analyze_One_Call (
4941                        N       => Call_Node,
4942                        Nam     => Hom,
4943                        Report  => False,
4944                        Success => Success);
4945
4946                      if Success then
4947                         Complete_Object_Operation (
4948                           Call_Node       => Call_Node,
4949                           Node_To_Replace => Node_To_Replace,
4950                           Subprog         => Hom_Ref);
4951
4952                         return True;
4953                      end if;
4954                   end if;
4955                end if;
4956
4957                Hom := Homonym (Hom);
4958             end loop;
4959
4960             --  Climb to ancestor type if there is one
4961
4962             exit when Etype (Anc_Type) = Anc_Type;
4963             Anc_Type := Etype (Anc_Type);
4964          end loop;
4965
4966          return False;
4967       end Try_Class_Wide_Operation;
4968
4969       -----------------------------
4970       -- Try_Primitive_Operation --
4971       -----------------------------
4972
4973       function Try_Primitive_Operation
4974         (Call_Node       : Node_Id;
4975          Node_To_Replace : Node_Id) return Boolean
4976       is
4977          Dummy       : Node_Id;
4978          Elmt        : Elmt_Id;
4979          Prim_Op     : Entity_Id;
4980          Prim_Op_Ref : Node_Id;
4981          Success     : Boolean;
4982
4983       begin
4984          --  Look for the subprogram in the list of primitive operations
4985
4986          Elmt := First_Elmt (Primitive_Operations (Obj_Type));
4987          while Present (Elmt) loop
4988             Prim_Op := Node (Elmt);
4989
4990             if Chars (Prim_Op) = Chars (Subprog)
4991               and then Present (First_Formal (Prim_Op))
4992             then
4993                Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
4994
4995                --  When both the type of the object and the type of the first
4996                --  formal of the primitive operation are tagged access types,
4997                --  we use a node with the object as first actual.
4998
4999                if Is_Access_Type (Etype (Obj))
5000                  and then Ekind (Etype (First_Formal (Prim_Op))) =
5001                             E_Anonymous_Access_Type
5002                then
5003                   --  Allocate the node only once
5004
5005                   if not Present (Call_Node_Case) then
5006                      Transform_Object_Operation (
5007                        Call_Node       => Call_Node_Case,
5008                        First_Actual    => Obj,
5009                        Node_To_Replace => Dummy,
5010                        Subprog         => Subprog);
5011
5012                      Set_Etype (Call_Node_Case, Any_Type);
5013                      Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
5014                   end if;
5015
5016                   Set_Name (Call_Node_Case, Prim_Op_Ref);
5017
5018                   Analyze_One_Call (
5019                     N       => Call_Node_Case,
5020                     Nam     => Prim_Op,
5021                     Report  => False,
5022                     Success => Success);
5023
5024                   if Success then
5025                      Complete_Object_Operation (
5026                        Call_Node       => Call_Node_Case,
5027                        Node_To_Replace => Node_To_Replace,
5028                        Subprog         => Prim_Op_Ref);
5029
5030                      return True;
5031                   end if;
5032
5033                --  Comment required ???
5034
5035                else
5036                   Set_Name (Call_Node, Prim_Op_Ref);
5037
5038                   Analyze_One_Call (
5039                     N       => Call_Node,
5040                     Nam     => Prim_Op,
5041                     Report  => False,
5042                     Success => Success);
5043
5044                   if Success then
5045                      Complete_Object_Operation (
5046                        Call_Node       => Call_Node,
5047                        Node_To_Replace => Node_To_Replace,
5048                        Subprog         => Prim_Op_Ref);
5049
5050                      return True;
5051                   end if;
5052                end if;
5053             end if;
5054
5055             Next_Elmt (Elmt);
5056          end loop;
5057
5058          return False;
5059       end Try_Primitive_Operation;
5060
5061    --  Start of processing for Try_Object_Operation
5062
5063    begin
5064       if Is_Access_Type (Obj_Type) then
5065          Obj_Type := Designated_Type (Obj_Type);
5066       end if;
5067
5068       if Ekind (Obj_Type) = E_Private_Subtype then
5069          Obj_Type := Base_Type (Obj_Type);
5070       end if;
5071
5072       if Is_Class_Wide_Type (Obj_Type) then
5073          Obj_Type := Etype (Class_Wide_Type (Obj_Type));
5074       end if;
5075
5076       --  Analyze the actuals in case of subprogram call
5077
5078       if Is_Subprg_Call and then N = Name (Parent (N)) then
5079          Actual := First (Parameter_Associations (Parent (N)));
5080          while Present (Actual) loop
5081             Analyze (Actual);
5082             Check_Parameterless_Call (Actual);
5083             Next (Actual);
5084          end loop;
5085       end if;
5086
5087       --  If the object is of an Access type, explicit dereference is
5088       --  required.
5089
5090       if Is_Access_Type (Etype (Obj)) then
5091          First_Actual :=
5092            Make_Explicit_Dereference (Sloc (Obj), Obj);
5093          Set_Etype (First_Actual, Obj_Type);
5094       else
5095          First_Actual := Obj;
5096       end if;
5097
5098       --  Build a subprogram call node
5099
5100       Transform_Object_Operation (
5101         Call_Node       => Call_Node,
5102         First_Actual    => First_Actual,
5103         Node_To_Replace => Node_To_Replace,
5104         Subprog         => Subprog);
5105
5106       Set_Etype (Call_Node, Any_Type);
5107       Set_Parent (Call_Node, Parent (Node_To_Replace));
5108
5109       return
5110          Try_Primitive_Operation
5111            (Call_Node       => Call_Node,
5112             Node_To_Replace => Node_To_Replace)
5113         or else
5114          Try_Class_Wide_Operation
5115            (Call_Node       => Call_Node,
5116             Node_To_Replace => Node_To_Replace);
5117    end Try_Object_Operation;
5118
5119 end Sem_Ch4;