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